使用文件对话框插入图片时出现Excel VBA路径错误

如何解决使用文件对话框插入图片时出现Excel VBA路径错误

我对以下代码有疑问。基本上，它按预期工作。这曾经可以正常工作，但是最近我在图像的保存路径上遇到了问题。 如果插入照片，一切正常。但是，如果在存储位置中更改了照片或其他用户无权访问该照片，则会出现错误消息，指出路径已更改。测试：从桌面插入一张照片，重命名该照片，重新打开文件->链接到已失效的照片。

我在这里什么也不能继续。有没有人提示如何将照片直接保存到Excel文件中？没有通往照片的路径？

我将非常感谢！

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

解决方法

谢谢！

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