Excel VBA Path error when inserting picture with file dialog

Question

I have a problem with the following code. Basically it works as intended. This used to work correctly, but recently I had a problem with the save path of the image. If I insert a photo, everything works. But if the photo is changed in the storage location or another user has no access to it, the error message appears that the path has been changed. For the test: Insert a photo from the desktop, rename the photo, reopen file -> link to photo dead.

I just can't get any further here. Does anyone have a tip on how to get the photo saved directly into the Excel file? Without path to the photo is needed?

I would be very grateful!

Sub InsertPicture()

If ThisWorkbook.ActiveSheet.Range("G10").Locked = True Then

    MsgBox "Form already sent. No more changes possible!"
    
Else:

    If ActiveSheet.Buttons("BtPicture").Text = "Insert picture" Then
    
        ThisWorkbook.ActiveSheet.Unprotect
        
        Dim profile As String
        On Error GoTo 0
        Dim fd As FileDialog
        
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        
        With fd
            .Filters.Clear
            .Filters.Add "Picture Files", "*.bmp;*.jpg;*.gif;*.png"
            .ButtonName = "Select"
            .AllowMultiSelect = False
            .Title = "Select the picture to import"
            .InitialView = msoFileDialogViewDetails
            '.Show
        End With
        
        If fd.Show = 0 Then
        
            Exit Sub
            
        Else:
            
            ActiveSheet.Range("Q14").Select
            
            With ActiveSheet.Pictures.Insert(fd.SelectedItems(1))
                .Left = ActiveSheet.Range("Q14").Left + 2
                .Top = ActiveSheet.Range("Q14").Top + 2
                .Placement = 1
                .PrintObject = True
                .Name = "PicName"
            End With
            
            ActiveSheet.Pictures("PicName").Select
            
            With Selection.ShapeRange
                .LockAspectRatio = msoFalse
                .Width = 259
                .Height = 178
            End With
            
            
            ActiveSheet.Buttons("BtPicture").Text = "Delete photo"
            ThisWorkbook.ActiveSheet.Protect
            
        End If
        
    Else:
    
        ThisWorkbook.ActiveSheet.Unprotect
        ActiveSheet.Pictures("PicName").Delete
        ActiveSheet.Buttons("BtPicture").Text = "Insert picture"
        ThisWorkbook.ActiveSheet.Protect
        
    End If
    
End If

End Sub

Answer 1

Thx!

Sub InsertPicture()

If ThisWorkbook.ActiveSheet.Range("G10").Locked = True Then

    MsgBox "Form already sent. No more changes possible!"
    
Else:

    If ActiveSheet.Buttons("BtPicture").Text = "Insert photo" Then
    
        ThisWorkbook.ActiveSheet.Unprotect
        
        Dim profile As String
        On Error GoTo 0
        Dim fd As FileDialog
        
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        
        With fd
            .Filters.Clear
            .Filters.Add "Picture Files", "*.bmp;*.jpg;*.gif;*.png"
            .ButtonName = "Select"
            .AllowMultiSelect = False
            .Title = "Select the picture to import"
            .InitialView = msoFileDialogViewDetails
            '.Show
        End With
        
        If fd.Show = 0 Then
        
            Exit Sub
            
        Else:
            
            ActiveSheet.Shapes.AddPicture(filename:=fd.SelectedItems(1), LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, Left:=302, Top:=221, Width:=259, Height:=178).Name = "PicName"
            
            ActiveSheet.Buttons("BtPicture").Text = "Delete picture"
            ThisWorkbook.ActiveSheet.Protect
            
        End If
        
    Else:
    
        ThisWorkbook.ActiveSheet.Unprotect
        ActiveSheet.Shapes("PicName").Delete
        ActiveSheet.Buttons("BtPicture").Text = "Insert photo"
        ThisWorkbook.ActiveSheet.Protect
        
    End If
    
End If

End Sub