在Excel中使用VBA时，将图片保存为图片而不是链接

Question

我有一个Excel文件的标签模板与6300项(每个项目有一个父ID匹配的图片名称，适合子项目)。

我发现代码将运行所有的方式没有错误(当项目丢失，例如)。
但是，当共享项目时，它将图片保存为链接而不是图片，并且任何人收到该文件都会收到一个断开的链接消息。

Sub Picture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long
lastrow = Worksheets("sheet2").Range("b1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
On Error GoTo errhandler:
Set pastehere = Cells(x, 1)
pasterow = pastehere.Row
Cells(pasterow, 1).Select 'This is where picture will be inserted
pictname = Cells(x, 3) 'This is the picture name
ActiveSheet.Pictures.Insert("C:UsersBennyCohenPicturesCatalogue pics" & pictname & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pasterow, 1).Left
.Top = Cells(pasterow, 1).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 140
.ShapeRange.Width = 80
.ShapeRange.Rotation = 0#
.linktofile = msoFalse
.savewithdocument = msoCTrue
End With
Next
errhandler:
Range("A" & x).Value = "Review"
Resume Next

End Sub

Answer 1

linktofile和savewithdocument不是图片属性，错误被errhandler中的Resume Next掩盖，见这里。使用Shapes.addPicture()

Sub Picture()
Const FOLDER = "C:UsersBennyCohenPicturesCatalogue pics"
Dim wb As Workbook, ws As Worksheet
Dim lastrow As Long, r As Long, pictname As String
Dim n As Long, m As Long
Set wb = ActiveWorkbook ' or ThisWorkbook
Set ws = wb.Sheets("Sheet2")
lastrow = ws.Range("B1").CurrentRegion.Rows.Count

For r = 2 To lastrow
pictname = FOLDER & ws.Cells(r, 3) & ".jpg" 'This is the picture name
' check file exists
If Len(Dir(pictname)) > 0 Then
With ws.Shapes.AddPicture(pictname, _
linktofile:=msoFalse, savewithdocument:=msoTrue, _
Left:=ws.Cells(r, 1).Left, _
Top:=ws.Cells(r, 1).Top, _
Height:=140, Width:=80)
.LockAspectRatio = msoFalse
.Rotation = 0#
End With
n = n + 1

Else
ws.Cells(r, "A") = "Review"
m = m + 1
End If
Next
MsgBox n & " Pictures inserted " & _
m & " Pictures to review", vbInformation

End Sub