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

Posted 2023-05-07

【中文标题】在 Excel 中使用 VBA 时将图片另存为图片而不是链接

【英文标题】：Save picture as a picture instead of link when using VBA in Excel

【发布时间】：2021-10-19 01:27:46

【问题描述】：

我有一个包含 6,300 个项目的标签模板的 Excel 文件（每个项目都有一个与适合子项目的图片名称匹配的父 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:\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

【参考方案1】：

linktofile 和savewithdocument 不是图片属性，错误被错误处理程序中的Resume Next 掩盖，请参阅here。使用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

【讨论】：

你是个传奇我爱你！