VBA Remove image link

[sanket_sk]

Hi All,

I am stuck in one of unique issue.

I was looking for a macro that will help to insert an image based on cell value.

I got the macro on the internet and modified it as per my requirement, this macro is working exactly the way I want however when I change or delete the image folder all the images are going vanished.

I tried to remove a link from an image but not succeeded, could you please help me understand what went wrong and how I can remove the link from the folder.

You may suggest another code also which will solve my problem.


Regards,
Sanket

Sub InsertPictures()


    Const fPath = "C:\Desktop\Final snap as 0n 28 Jun\"

    Dim cel As Range, picPath As String, shp As Shape
'insert imagess
    For Each cel In Range("M4", Range("M" & Rows.Count).End(xlUp))
        On Error Resume Next
        picPath = fPath & "\" & cel.Value & ".jpg"
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            With cel.Parent.Pictures.Insert(picPath, LinkToFile = False)
                With .ShapeRange
                    .LinkToFile = msoFalse
                    .savewithdocument = msoCTrue
                    .LockAspectRatio = msoFalse
                    .LinkToFile = False
                    .savewithdocument = True
                    .LockAspectRatio = False
                    .Width = 100
                    .Height = 100
                End With
                .Left = cel.Offset(, 1).Left
                .Top = cel.Offset(, 1).Top
            End With
        End If
    Next cel
End Sub

 

[Georgiboy]

Try the below:

Sub InsertPictures()
    Dim cel As Range, picPath As String, shp As Shape
    
    Const fPath = "C:\Users\jbloggs\Desktop\test"
    
    For Each cel In Range("A1", Range("A" & Rows.Count).End(xlUp))
        picPath = fPath & "\" & cel.Value & ".jpg"
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            Set shp = Sheet1.Shapes.AddPicture(picPath, msoFalse, msoCTrue, 0, 0, 100, 100)
            With shp
                .Left = cel.Offset(, 1).Left
                .Top = cel.Offset(, 1).Top
            End With
        End If
    Next cel
End Sub