Excel 使用 shapes.AddPicture VBA 宏将 URL 中的图像添加到工作簿

Question

所以我有以下代码可以正常工作，并使用带有 URL 的列将图像添加到下一列。问题是，如果您将它发送给某人，它就会损坏。我想将其切换为 shapes.AddPicture，这样图片就会跟随电子表格。我找到了一些可行的方法，但它不会像下面的解决方案那样将图片添加到单个单元格中。

 Sub URLPictureInsert()

    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("T3:T25")
    For Each cell In Rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column + 1
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            .Width = 70
            .Height = 100
            .Top = xRg.Top + (xRg.Height - .Height) / 2
            .Left = xRg.Left + (xRg.Width - .Width) / 2
        End With
lab:
    Set Pshp = Nothing
    Range("T2").Select
    Next
    Application.ScreenUpdating = True
End Sub

这个有效，但它会在同一区域中将图像一个接一个地添加 - 我希望它能像上面的那样动态放置图像

Sub URLPhotoInsert()
    Dim cShape As Shape
    Dim cRange As Range
    Dim cColumn As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set xRange = ActiveSheet.Range("j3:j4")
    For Each cell In xRange
        cName = cell
        ActiveSheet.Shapes.AddPicture (cName), True, True, 100, 100, 70, 70
        Set cShape = Selection.ShapeRange.Item(1)
        If cShape Is Nothing Then GoTo line22
        cColumn = cell.Column - 1
        Set cRange = Cells(cell.Row, cColumn)
      
line22:
        Set cShape = Nothing
        Range("D5").Select
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

我终于找到了对我有用的东西 - 对于那些想要使用 URL 作为源

与文件一起存储图片的人

 Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String

Sub URLPictureInsert()
    Dim theShape As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    ' Set to the range of cells you want to change to pictures
    Set rng = ActiveSheet.Range("T1206:T1400")
    For Each cell In rng
        Filename = cell
        ' Use Shapes instead so that we can force it to save with the document
        Set theShape = ActiveSheet.Shapes.AddPicture( _
            Filename:=Filename, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, _
            Left:=cell.Left, Top:=cell.Top, Width:=15, Height:=15)
        If theShape Is Nothing Then GoTo isnill
        With theShape
            .LockAspectRatio = msoTrue
            ' Shape position and sizes stuck to cell shape
            .Top = cell.Top + 1
            .Left = cell.Left + 1
            .Height = cell.Height - 2
            .Width = cell.Width - 2
            ' Move with the cell (and size, though that is likely buggy)
            .Placement = xlMoveAndSize
        End With
        ' Get rid of the
        cell.ClearContents
isnill:
        Set theShape = Nothing
        Range("D2").Select

    Next
    Application.ScreenUpdating = True

    Debug.Print "Done " & Now


End Sub

Excel 使用 shapes.AddPicture VBA 宏将 URL 中的图像添加到工作簿

Excel add image to workbook from URL using shapes.AddPicture VBA Macro

excel

vba

url