Modify VBA to insert picture embedded in file instead of a link to a picture

Hello all!

Hoping somebody can help me here, I'm way beyond my knowledge base and out of my comfort zone with this problem!

I currently use a macro to insert pictures to a specific cell, when I click the assigned button, it opens the file browser, allows me to choose my picture, and then asks to select the cell I wish it to be fitted to, however this works fine until the document leaves my laptop where the pictures are only linked to, instead of being saved with the document.

I understand this problem is caused by newer versions of excel (circa 2013 onwards?) and that the solution is to change it from a picture insert to a shape insert as a picture, but I cannot get a macro to work with these commands because I do not fully understand them.

If somebody can guide me on this, that would be much appreciated, I have attached my code used currently below:

Sub PhotoInsert()
Dim sFile As Variant, r As Range
sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
If sFile = False Then Exit Sub
On Error Resume Next
Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Count > 1 Then Exit Sub
ActiveSheet.Pictures.Insert (sFile)
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.LockAspectRatio = False
.Top = r.Top
.Left = r.Left
.Height = r.MergeArea.Height
.Width = r.MergeArea.Width
End With
End Sub

I believe it will then just be this part that needs changing?

ActiveSheet.Pictures.Insert (sFile)
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.LockAspectRatio = False
.Top = r.Top
.Left = r.Left
.Height = r.MergeArea.Height
.Width = r.MergeArea.Width
End With
End Sub

Originally Posted by 6StringJazzer

Try this. It works but I am not able to test whether it is portable to another machine--the documentation says it should be.

Sub PhotoInsert()

   Dim sFile As Variant, r As Range
   
   sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
   If sFile = False Then Exit Sub
   On Error Resume Next
   Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)
   On Error GoTo 0
   If r Is Nothing Then Exit Sub
   If r.Count > 1 Then Exit Sub
   Shapes.AddPicture Filename:=sFile, _
                     linktofile:=msoFalse, _
                     savewithdocument:=msoCTrue, _
                     Left:=r.Left, _
                     Top:=r.Top, _
                     Height:=r.MergeArea.Height, _
                     Width:=r.MergeArea.Width
End Sub

Thanks Jeff appreciate the reply,

I just tried it, however when I select the photo, and then the cell in which I wish it to be held, it gives me a run time error "424" with a message saying "object required". If I run the debug part, it highlights your modification yellow? I hope that helps?

If your code is not in the target worksheet then you will need to qualify it. I don't recommend using ActiveSheet but to be consistent, this change will fix that problem:

ActiveSheet.Shapes.AddPicture Filename:=sFile, _

I got this from someone somewhere.
In 2013 it seems to work.

Sub Insert_Image()
Dim ary, img As Object
Application.ScreenUpdating = False
    ChDir "C:\Picture Folder"
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then
            ary = Split(.SelectedItems(1), "\")
            Range("I6").Value = "Current Picture: " & ary(UBound(ary))
            Set img = ActiveSheet.Pictures.Insert(.SelectedItems(1))
        
            img.Left = 0
            img.Top = 0

Originally Posted by 6StringJazzer

If your code is not in the target worksheet then you will need to qualify it. I don't recommend using ActiveSheet but to be consistent, this change will fix that problem:

ActiveSheet.Shapes.AddPicture Filename:=sFile, _

Thanks Jeff, that has fixed it.

Can you elaborate on why it fixed it for my understanding? The object the error was referring to was not the picture itself then, more the destination?