Question

我一直在使用Excel VBA宏从办公室服务器上的文件夹将图像添加到电子表格列表中。该列表从我的数据库软件中导出，列A中包含文件夹和图像名称（例如038/19761809.jpg）。现在，我需要将这些文档发送给我办公室以外的人员，而无需访问我们的服务器，因此我尝试从使用ActiveSheet.Pictures.Insert切换到使用更正确 ActiveSheet.Shapes.AddPicture。目标是将图像文件嵌入文档中，而不是仅链接到我们办公室服务器上的文件。

此代码（使用Pictures.Insert）将图像插入为链接。当我通过电子邮件将电子表格发送给异地用户时，由于收件人的计算机找不到链接的图像，因为它们的计算机不在我们的本地网络上，因此它们无法找到。

Sub InsertPictures()
 Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "S:\pp4\images\"
 MyRange = "A2:A275"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.Value) > 0 Then
        picname = Mypath & rcell.Value
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub

Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Pictures.Insert(picname).Select
    On Error GoTo 0

    With Selection
     .Left = myleft + 4
     .Top = mytop + 4
     .ShapeRange.LockAspectRatio = msoTrue
     .ShapeRange.Height = 115#
     .ShapeRange.Rotation = 0#
    End With
Exit Sub
ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

我已修改我的代码以使用Shapes.AddPicture的格式。这是新代码：

Sub InsertPictures()
 Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "S:\pp4\images\"
 MyRange = "A2:A275"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.Value) > 0 Then
        picname = Mypath & rcell.Value
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub

Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Shapes.AddPicture(Filename:=picname, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=myleft + 4, Top:=mytop + 4, LockAspectRatio:=msoTrue, Height:=115#, Rotation:=0#).Select
    On Error GoTo 0
Exit Sub
ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

当我尝试运行新的宏时，Excel只会显示我的“无法找到照片”错误消息。您能帮我找出我做错了什么吗？感谢您的帮助！

Answer 1

您在Shapes.AddPicture（LockAspectRatio，Rotation）中有两个额外的参数，而缺少一个（Width）。

在下面查看有关Shapes.AddPicture的更多详细信息以及更正的代码：

Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)

    Dim sht As Worksheet: Set sht = ActiveSheet
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    With sht.Shapes
        .AddPicture _
            Filename:=picname, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=myleft + 4, _
            Top:=mytop + 4, _
            Width:=-1, _
            Height:=115

    End With
    On Error GoTo 0
Exit Sub
ErrNoPhoto:
    Debug.Print "Unable to Find Photo" 'Shows message box if picture not found
End Sub

PS：我建议您阅读有关避免在所有内容中使用.Select的信息...

Excel VBA-Shapes.AddPicture与Pictures.Insert从映射的驱动器插入电子表格

1 个答案: