用vba插入图片

我正在尝试使用VBA插入图像，但代码只将图像链接到Excel表单。 一旦我删除了图像，表格中的链接图像被删除。 我需要调整代码以将链接的图像保存到工作簿中。 这是我的代码

Sub DeleteImages() For Each s In ActiveSheet.Shapes s.Delete Next s ActiveSheet.Cells.Rows.AutoFit End Sub Sub AddImages() Dim sImgFile As String sPath = ActiveWorkbook.Path & Application.PathSeparator Set ws = ActiveSheet ltop = Val(InputBox("Provide height", "Height")) 'lwid = Val(InputBox("Provide width", "Width")) 'On Error GoTo StopIt If ltop > 0 Then 'And lwid > 0 ws.Range("E1").ColumnWidth = 1 For l = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & l).Rows.AutoFit sImgFile = Dir(sPath & ws.Range("B" & l).Value & ".*") If sImgFile <> "" Then With ws.Pictures.Insert(sPath & sImgFile) With .ShapeRange .LockAspectRatio = msoTrue '.Width = lwid .Height = ltop i = 1 ws.Range("E" & l).ColumnWidth = Application.WorksheetFunction.Max(.Width / 5.3, ws.Range("E" & l).ColumnWidth) ws.Range("E" & l).RowHeight = .Height + 4 End With .Left = ws.Cells(l, 5).Left .Top = ws.Cells(l, 5).Top + 2 .Placement = 1 .PrintObject = True Call Macro1(Range("E" & l)) End With End If Next l End If For Each s In ActiveSheet.Shapes s.Left = ws.Range("E1").Left + (ws.Range("E1").Width - s.Width) / 2 Next s StopIt: On Error GoTo 0 End Sub 

Answer 1

尝试这个：

  If sImgFile <> "" Then With ws.Shapes.AddPicture(sPath & sImgFile, linktofile:=msoFalse, _ savewithdocument:=msoCTrue) .LockAspectRatio = msoTrue '.Width = lwid .Height = ltop i = 1 ws.Range("E" & l).ColumnWidth = Application.WorksheetFunction.Max(.Width / 5.3, ws.Range("E" & l).ColumnWidth) ws.Range("E" & l).RowHeight = .Height + 4 .Left = ws.Cells(l, 5).Left .Top = ws.Cells(l, 5).Top + 2 .Placement = 1 .ControlFormat.PrintObject = True Call Macro1(Range("E" & l)) End With End If