Insert Picture with vba creating a link

[Jimmypop]

Good day

I have the following code which was obtained somewhere on the net (cant remember where). It works perfectly for what I want to do.

However when sending the file to another user, the pictures disappear and it says that the linked image cannot be displayed it may have been moved. How would code change to prevent this?

Sub Insert_Picture()
    On Error GoTo ErrorHandler
    result = MsgBox("Do you want to upload a picture?", vbYesNo + vbQuestion, "Message from VFL...")
    If result = vbYes Then

    Const cBorder As Double = 5     ' << change as required
    
    Dim sPicture As String, pic As Picture
    
    sPicture = Application.GetOpenFile("Pictures (*.png; *.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
    
    If sPicture = "False" Then Exit Sub
    
    Set pic = ActiveSheet.Pictures.Insert(sPicture)
    With pic
        .ShapeRange.LockAspectRatio = False       ' << change as required
        
        If Not .ShapeRange.LockAspectRatio Then
            .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
        Else
            If .Width >= .Height Then
                .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            Else
                .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
            End If
        End If
        .Top = ActiveCell.MergeArea.Top + cBorder
        .Left = ActiveCell.MergeArea.Left + cBorder
        .Placement = xlMoveAndSize
    End With
    
    Set pic = Nothing
End If
ErrorHandler: Exit Sub
End Sub

 

[Jimmypop]

Apologies... saw a nminor mistake when I copied the code... correct code below:

sPicture = Application.GetOpenFile("Pictures (*.png; *.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")

supposed to read

sPicture = Application.GetOpenFileName("Pictures (*.png; *.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")

However it still does the link thing.

 

[Jimmypop]

Update...

After playing around with different pieces of code I managed to get it working with code below. Hope this will assist someone with similar problem. Just a side note that this code works with a merged area or cells and not just a single cell.

Sub Insert_Picture()
    result = MsgBox("Do you want to upload a picture?", vbYesNo + vbQuestion, "Message from VFL...")
    If result = vbYes Then
    Dim sFileName As String
    Dim oShape As Shape
        If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
        sFileName = Application.GetOpenFilename( _
        FileFilter:="Images (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        FilterIndex:=1, _
        Title:="Insert Picture", _
        ButtonText:="Submit to VFL", _
        MultiSelect:=False)
    If sFileName = "False" Then Exit Sub
        With ActiveCell.MergeArea
        ActiveSheet.Shapes.AddPicture _
                Filename:=sFileName, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=.Left + 5, _
                Top:=.Top + 5, _
                Width:=.Width - 10, _
                Height:=.Height - 10
    End With
    End If
End Sub