excel 2010 VBA InsertPicInRange only makes shortcut to image instead of copy of image

Hello guru's

I have a problem.

I am using a VBA script which worked fine when I used office 2003.
This script was created by my colleague how has left the building so to speak.
I myself have no experience with macro's / VBA scripts.

When we switched to Excel 2010 it seemed to run fine but with the difference that the images were no longer copied to the worksheet.
Only a shortcut is added to the cell(s).

When I e-mail the worksheet the receiver cannot see the images which where added.
I can see the images in the excel document but only when the t:\ drive is available.
If I disconnect this network drive then I have the same problem.

Below is the code:

Sub InsertPicInRange()
'
' InsertPicInRange Macro
' De macro is opgenomen op 24-6-2005 door sb.
'
' Sneltoets: CTRL+SHIFT+Q
'
Dim strRange As String
Dim strRange2 As String


strRange = "A12"
For I = 12 To 200
 strRange = "A" & I
 strRange2 = "B" & I & ":" & "B" & I
 InsertPictureInRange "t:\" & Worksheets("Offerte").Range(strRange), _
        Range(strRange2)

Next I


End Sub


Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "t:\" Then Exit Sub
    If Right(PictureFileName, 4) <> ".jpg" Then PictureFileName = PictureFileName + ".jpg"
    'import picture
    On Error GoTo JUMPNEXT
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    GoTo ENDSTATEMENT
    
JUMPNEXT:
    PictureFileName = "T:\" & Right(PictureFileName, 10)
    If Not IsNull(p) Then GoTo FIN Else GoTo ENDSTATEMENT
    
ENDSTATEMENT:
    ' determine positions
    'On Error GoTo FIN
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing

FIN:
End Sub

Does anyone have an anwser to this problem?

try this

Sub TestInsertPicture()
Dim imagefile As String
imagefile = "C:\Users\john\Pictures\casse.jpeg"
InsertPicture imagefile, Range("D10"), True, True
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
    CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        If CenterH Then
            w = .Offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .Offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

Hello Patel,

Thanks for your very quick reply.

But I think I was unclear in posting the complete script in the post.
The first portion is a test bit and not used anymore.

The problem lies in the second bit.
In the "Sub InsertPicInRange".
The "Sub TestInsertPicture" isn't used.

Sorry for the inconvenience.

Never the less I have tried your suggestion but it makes no difference.

Sub InsertPicInRange()
'
' InsertPicInRange Macro
' De macro is opgenomen op 24-6-2005 door sb.
'
' Sneltoets: CTRL+SHIFT+Q
'
Dim strRange As String
Dim strRange2 As String


strRange = "A12"
For I = 12 To 200
 strRange = "A" & I
 strRange2 = "B" & I & ":" & "B" & I
 InsertPictureInRange "t:\" & Worksheets("Offerte").Range(strRange), _
        Range(strRange2)

Next I


End Sub


Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "t:\" Then Exit Sub
    If Right(PictureFileName, 4) <> ".jpg" Then PictureFileName = PictureFileName + ".jpg"
    'import picture
    On Error GoTo JUMPNEXT
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    GoTo ENDSTATEMENT
    
JUMPNEXT:
    PictureFileName = "T:\" & Right(PictureFileName, 10)
    If Not IsNull(p) Then GoTo FIN Else GoTo ENDSTATEMENT
    
ENDSTATEMENT:
    ' determine positions
    'On Error GoTo FIN
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing

FIN:
End Sub

Originally Posted by ArjanSpit

The problem lies in the second bit.
In the "Sub InsertPicInRange".
The "Sub TestInsertPicture" isn't used.

you have to run Sub TestInsertPicture(), not other sub, don't mix my code with your.

don't use Pictures.Insert use shapes.Addpicture instead because that allows you to specify whether to link or not