Insert Picture with vba creating a link

Jimmypop

Board Regular
Joined
Sep 12, 2013
Messages
123
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?

VBA Code:
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
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Jimmypop

Board Regular
Joined
Sep 12, 2013
Messages
123
Apologies... saw a nminor mistake when I copied the code... correct code below:

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

supposed to read

VBA Code:
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

Board Regular
Joined
Sep 12, 2013
Messages
123
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.

VBA Code:
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
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,129,864
Messages
5,638,746
Members
417,049
Latest member
baka416

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top