使用服务器路径中的图像在 Excel 中动态插入

Question

我有下面的代码在我们服务器的特定文件夹中查找 sku 的图像并插入 /autosize - 但我遇到的问题是，如果我将此电子表格发送给不在服务器上的其他人，他们看不到图片。 有人可以帮助解决这个问题，以便动态插入图像吗？我相信这是在工作表更新/打开时将实际图像放置在工作表中而不是链接回必须做的事情。 或者，如果图像未链接到服务器，我该如何格式化以发送并包含图像？ 我查看了其他有关动态插入的帖子，但我无法正常工作

Sub Imageupdate()
' inserts the picture files listed in col A into the workbook,
' and sizes and centers in col B

Const sPath       As String = "S:\Images\Casio\"
'Const sPath       As String = "C:\Users\shg\Pictures\shg"
Dim cell          As Range
Dim sFile         As String
Dim oPic          As Picture

For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
sFile = sPath & cell.Text & ".jpg"
If Len(Dir(sFile)) Then
  Set oPic = ActiveSheet.Pictures.Insert(sFile)
  oPic.ShapeRange.LockAspectRatio = msoTrue

  With cell.Offset(, 1)
    If oPic.Height > .Height Then oPic.Height = .Height
    If oPic.Width > .Width Then oPic.Width = .Width

    oPic.Top = .Top + .Height / 2 - oPic.Height / 2
    oPic.Left = .Left + .Width / 2 - oPic.Width / 2
  End With
Else
  cell.Select
  MsgBox sFile & " not found"
End If
Next cell
End Sub

Answer 1

根据问题VBA to insert embedded picture 的两个答案，使用Shapes.AddPicture（或Shapes.AddPicture2，如果您想在插入时压缩图片。）

• LinktoFile 是 msoFalse
• SaveWithDocument 是 msoTrue
• Width 和 Height 分别为-1 以保留图片的现有尺寸

---

Sub ImageUpdate()
' inserts the picture files listed in col A into the workbook,
' and sizes and centers in col B

Const sPath       As String = "S:\Images\Casio\"
'Const sPath       As String = "C:\Users\shg\Pictures\shg"
Dim cell          As Range
Dim sFile         As String
Dim shpPic        As Shape
Dim ws            As Worksheet: Set ws = ActiveSheet

With ws
    For Each cell In .Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp))
        sFile = sPath & cell.Text & ".jpg"

        If Len(Dir(sFile)) Then
            Set shpPic = .Shapes.AddPicture(sFile, msoFalse, msoTrue, 0, 0, -1, -1)
            shpPic.LockAspectRatio = msoTrue

            With cell.Offset(, 1)
                If shpPic.Height > .Height Then shpPic.Height = .Height
                If shpPic.Width > .Width Then shpPic.Width = .Width

                shpPic.Top = .Top + .Height / 2 - shpPic.Height / 2
                shpPic.Left = .Left + .Width / 2 - shpPic.Width / 2
            End With
        Else
            cell.Select
            MsgBox sFile & " not found"
        End If
    Next cell
End With

End Sub