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

Question

I have an excel file for label template with 6,300 items (each item has a parent ID which matches the picture name that suits the child item), I was able after a lot of searching to find a code that will run all the way through with out an error (when items are missing for example). However when I want to share the item it has the pictures saved as a link instead of an actual picture, and whoever receive that file will have a broken link message. Can anyone help me change my code to save as picture?

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:\Users\BennyCohen\Pictures\Catalogue 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

Thanks in advance, live long and prosper ;)

Answer 1

linktofile and savewithdocument are not picture properties and the error is masked by the Resume Next in the errhandler, see here . Use Shapes.addPicture() .

Sub Picture()

    Const FOLDER = "C:\Users\BennyCohen\Pictures\Catalogue 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