无法使用 VBA 在 Excel 中插入图片

Question

我对这个问题感到非常疯狂，请帮助我。

我制作了一个 shell 脚本，它在文本文件中写入存储在文件夹中的一些图像的路径。 然后我使用 excel 代码读取每个路径并将其写入 excel 单元格。 然后我制作了一个应该采用该路径并使用它来插入图片的代码。 我试过 Pictures.insert(path) 和 shapes.addpictures "path"，但每次都遇到同样的问题，图片无法加载。 奇怪的是，如果我之前手动插入图片然后删除，代码会完美加载图片。 但如果是第一次，那就没有了。 我使用的路径如下所示：“/Users/theodorebedos/Documents/code_tilly/new_pict_tilly/IMG_9040.jpg”

我正在使用Mac，也许这很重要？

Private Sub Convert_Img()

Dim myPict As Picture
Dim PictureLoc As String
Dim EndPictRow, i As Integer
Dim StartPath As String


If Worksheets("Main").Cells(3, 1).Value <> "" Then
    EndPictRow = Worksheets("Main").Range("A2").End(xlDown).Row

    For i = 3 To EndPictRow
        PictureLoc = Worksheets("Main").Cells(i, 1).Value
        Worksheets("Main").Cells(i, 1).ClearContents
        Worksheets("Main").Cells(i, 1).ColumnWidth = 30
        Worksheets("Main").Cells(i, 1).RowHeight = 150
           ActiveSheet.Shapes.AddPicture PictureLoc, False, True, Worksheets("Main").Cells(i, 1).Left, Worksheets("Main").Cells(i, 1).Top, Worksheets("Main").Cells(i, 1).Width, Worksheets("Main").Cells(i, 1).Height

    Next i
End If

End Sub

编辑：当我使用“Pictures.insert”或“shapes.addpicture path, true, true”时，我在 VBA 中没有错误消息，但我在 excel 中而不是我的图片中有一个空白图像，其中包含如下错误消息：图像

如果我使用“shapes.addpicture 路径，FALSE，true”，那么我会收到这样的错误消息，但根本没有加载图像：图像 2

然后是这样的错误1004： image3

如果我执行该过程以获得图像 1，然后我保存文档，重新打开它，我将直接获得：图像 4

谢谢你的帮助。 将不胜感激。

Answer 1

我简化了您的代码，因此可以看到它在做什么。 请注意，我避免从刚刚设置或显而易见的单元格属性中读取值。

1. 一旦设置了列宽，其中所有单元格的宽度都是相同的。
2. 列中所有单元格的 Left 属性始终相同。
3. 如果列是 A 列，则 Left 始终为 0。

当然，您试图实现的是只输入一次值。 这是一个很好的做法，但从工作表中读取属性很慢。 更快的方法——更少的代码量和更好的可读性——是在顶部声明一个常量并在代码中使用该名称。

所以你最终得到了这段代码。

Private Sub Convert_Img()

    Const ClmWidth As Single = 30
    Const RowHight As Single = 150

    Dim EndPictRow As Long, R As Long
    ' sorry, I recommend i for arrays and R for rows (C for columns)


    With Worksheets("Main")
        ' End(xlDown) will find the first blank cell below the base cell.
        '   There might be more filled cells further down.
        ' End(xlUp) will find the first used cell above the base cell
        '   disregarding more blanks above that one.
        EndPictRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        ' no need to set the column width multiple times in the loop
        .Columns(1).ColumnWidth = ClmWidth

        ' this loop will never run if R < EndPicRow
        For R = 3 To EndPictRow
            With .Cells(R, 1)
                .RowHeight = RowHight
                ' this will work only once:-
                .Worksheet.Shapes.AddPicture CStr(.Value), False, True, 0, .Top, ClmWidth, RowHight
            End With
        Next R
    End With
End Sub

它只工作一次的原因变得非常明显。 新图片从单元格的Value中获取其源路径。 当然，一旦您在单元格中插入图片（图像），该值就不能再成为路径（字符串）。 如果您再次运行该代码，它将失败。 但是，如果这是您的需要，应该可以从定义单元格中图片的公式中提取路径。 鉴于图片本身不存在于该位置，公式应保存路径或对工作簿背景数据中某个位置的引用，具体取决于它的加载方式。

Answer 2

编辑：根据您的评论，我查看了在 Mac 上运行 VBA 时如何指定文件路径，并找到了 Ron de Bruin 的这篇文章。 原来你必须使用“:”作为你的路径分隔符而不是“/”。

这应该可以解决您在.AddPicture方法中遇到的问题，但为了.AddPicture ，我仍然会在下面留下我的原始答案。

---

您描述的问题似乎与此问题相同。 不幸的是，那里提供的答案似乎也不能真正解决您的问题。

我没有 Mac，因此无法对此进行测试，但我建议您尝试这种潜在的解决方法：您可以插入一个矩形，然后用您想要的图片填充它，而不是插入图片。

代码如下所示：

Sub AddFilledRectangle()

    Dim FullFileName As String
    FullFileName = "Users:File:Path:img.jpg"

    Dim MyShapeTop As Double, MyShapeLeft As Double, MyShapeWidth As Double, MyShapeHeight As Double
    MyShapeTop = 100
    MyShapeLeft = 100
    MyShapeWidth = 100
    MyShapeHeight = 100

    'Create a new rectangular Shape
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, MyShapeLeft, MyShapeTop, MyShapeWidth, MyShapeHeight)

    'Change the filling options
    With shp.Fill
        .Visible = msoTrue
        .UserPicture FullFileName
        .TextureTile = msoFalse
        .RotateWithObject = msoTrue
    End With

End Sub

希望这适用于 Mac 版本的 Excel。

Answer 3

好的，所以它还不完美，但我关闭了循环并使用了 Dir()，正如你所说的 @Variatus。当我执行命令 Dir() 时，会打开这样的弹出窗口。 它询问我访问文件的授权。 我按下是，然后它起作用了。 它有效，但仅适用于该文件。 所以我想，我现在走对了，我需要在运行代码之前找到如何访问该文件夹中的所有文件。 我不能为他们所有人做这件事。 非常感谢。

Answer 4

我希望有人会从这个旧线程中受益。 事实证明，这是在其中一条评论中已经提到的某种权限问题，可能只发生在 OSX 上的 Excel 16 宏中。

似乎 Excel 缺乏访问链接资源的权限，并且没有要求它们。 我们需要授予文件夹中所有文件的权限。 下面的代码演示了如何实现这一点，假设构建路径的标识符在 A2:20 列中。 运行此宏（调整路径的构建方式），然后在对话框出现后授予访问权限：

Sub GrantAccess()
    Dim cName As Variant
    Dim files() As Variant
    Set xRange = ActiveSheet.Range("A2:A20")
        For Each cell In xRange
                 ReDim Preserve files(1 To cell.Row - 1)
                 cName = "/Users/adjust-your-path/path" & Cells(cell.Row, "A") & "_thumb_600.png"
                 files(cell.Row - 1) = cName
        Next
        fileAccessGranted = GrantAccessToMultipleFiles(files)
End Sub

使用的代码：

Sub URLPICInsertMM()
    Dim cShape As Shape
    Dim cRange As Range
    Dim cColumn As Long
    Dim cName As String
    Dim img As Picture
    Application.ScreenUpdating = False
    Set xRange = ActiveSheet.Range("B2:B10")
    For Each cell In xRange
        'cName = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
        ' files are located in thumbs sub-directory       
        cName = "/Users/.../IonChannels/thumbs/" & Cells(cell.Row, "A") & "_thumb_300.png"
        Set img = ActiveSheet.Pictures.Insert(cName)
        img.Select
        Set cShape = Selection.ShapeRange.Item(1)
        If cShape Is Nothing Then GoTo line22
        Cells(cell.Row, "C").Value = "file://" & cName
        Set cRange = Cells(cell.Row, cell.Column)
        With cShape
            .LockAspectRatio = msoTrue
            'If .Width > cRange.Width Then .Width = cRange.Width
            If .Height > cRange.Height Then .Height = cRange.Height
            .Top = cRange.Top + (cRange.Height - .Height)
            .Left = cRange.Left + (cRange.Width - .Width)
        End With
line22:
        Set cShape = Nothing
        Range("T2").Select
    Next
    Application.ScreenUpdating = True
End Sub

编辑：

证据：

我创建了一个简单的测试表（想法是将一些蛋白质可视化拇指加载到 Excel 表中），在 A 列中有一个标识符，图像文件描述符由标识符 + 路径和文件扩展名构成。 图像插入 B 列，文件描述符作为文本插入 C 列。

当我第一次运行宏时，只加载了第一张图像。 Excel 将文件描述符格式化为超链接。 单击file:///...链接时，Excel 会打开一个对话框，要求授予该文件的权限（屏幕截图）。 如果我授予访问权限并接受警告，然后再次运行宏，就会出现图像。

再次运行宏后，显示图像：