将多张图片导入 Excel 并在另一台计算机上打开文件

Question

我已经设法从其他来源收集了一些 VBA 代码（非常感谢），以创建大约 80% 完成的东西。但是，当我在另一台计算机上发送或打开电子表格时，我的图片不会出现（只是一个红色的 X）。

我的研究使我使用并插入 ActiveSheet.Shapes.AddPicture 方法但是我不确定如何将其构建到我的功能代码中/将其放置在哪里。我在Column D 中有文件名，这些文件名与我文件夹中存储的图片有关。图片被加载到 C 列，这一切都很好，我有大约 550 个 jpeg 文件。但是，一旦它关闭我的计算机，我就无法查看图像

我的工作代码是：

Sub InsertPicsr1Reg()
    Dim fPath As String, fName As String
    Dim r As Range
    Dim shp As Shape
    Application.ScreenUpdating = False
    fPath = "\Desktop\test workings\"
    For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
        On Error GoTo errHandler
        If r.Value <> "" Then
            With ActiveSheet.Pictures.Insert(fPath & r.Value)
                .ShapeRange.LockAspectRatio = msoTrue
                .Top = Cells(r.Row, 3).Top
                .Left = Cells(r.Row, 3).Left
                If .ShapeRange.Width > Columns(3).Width Then .ShapeRange _
                    .Width = Columns(3).Width
                Rows(r.Row).RowHeight = .ShapeRange.Height
            End With
        End If
errHandler:
        If Err.Number <> 0 Then
            Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
            On Error GoTo -1
        End If
    Next r
    For Each shp In ActiveSheet.Shapes
        shp.Placement = xlMoveAndSize
    Next shp
    Application.ScreenUpdating = True
End Sub

Answer 1

试试这个：

Sub InsertPicsr1Reg()
Dim fPath As String, fName As String
Dim r As Range
Dim shp As Shape
Application.ScreenUpdating = False
fPath = "\Desktop\test workings\"
For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
    If r.Value <> "" Then

        With ActiveSheet
            .Shapes.AddPicture fPath & r.Value, _
                msoFalse, msoTrue, _
                .Cells(r.Row, 3).Left, _
                .Cells(r.Row, 3).Top, _
                .Columns(3).Width, _
                .Rows(r.Row).Height
        End With

     end if
   next
end sub