有没有办法创建一个宏，将这些超链接转换为Excel中的嵌入图像？

Question

我经常生成多行图像的电子表格。在我们的数据库切换平台之前，我能够使用宏将超链接转换为嵌入图像。但是，由于切换平台，超链接的生成方式不同，并且宏不再起作用。

这是我们将使用的原始宏：

Sub URLPictureInsert()
    Dim theShape As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set rng = ActiveSheet.Range("J2:J10")
    For Each cell In rng
        Filename = cell
        Set theShape = ActiveSheet.Shapes.AddPicture( _
            Filename:=Filename, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, _
            Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
        If theShape Is Nothing Then GoTo isnill
        With theShape
            .LockAspectRatio = msoTrue
            .Top = cell.Top + 1
            .Left = cell.Left + 1
            .Height = cell.Height - 2
            .Width = cell.Width - 2
            .Placement = xlMoveAndSize
        End With
        ' Get rid of the
        cell.ClearContents
isnill:
        Set theShape = Nothing
        Range("A2").Select

    Next
    Application.ScreenUpdating = True

    Debug.Print "Done " & Now

End Sub

以下是超链接的生成方式：

动物照片
httpsa//www.shelterluv.com/sites/default/files/animal_pics/18283/2024/10/05/09/20241005093116.png
https://www.shelterluv.com/sites/default/files/animal_pics/18283/2024/10/17/11/20241017114413.png
https://www.shelterluv.com/sites/default/files/animal_pics/18283/2024/10/18/16/20241018163656.png

这些是现在生成超链接的方式，到宏不起作用的地方：

动物照片
https://sl-v2-prod.s3.us-west-2.amazonaws.com/profile-pictures/2e60d1118c35ca2072583c8757e270d5/8bb5679c4913dfeeab2587cab85fe199.jpg
https://sl-v2-prod.s3.us-west-2.amazonaws.com/profile-pictures/e6663723d3c1bd8ea9f2e961270659de/20241106165702.png
https://sl-v2-prod.s3.us-west-2.amazonaws.com/profile-pictures/5dcc1cdbd850cbe22283ce75d597dcff/20241106181308.png

Answer 1

我在上面的评论中发布的链接中描述了该问题 - 您可以通过首先将每个图像下载到临时文件，然后从那里插入来解决该问题。

Sub URLPictureInsert()
    Dim theShape As Shape, rng As Range, cell As Range, Filename As String
    Dim tempPath As String
    
    'On Error Resume Next
    'Application.ScreenUpdating = False
    Set rng = ActiveSheet.Range("A2:A10")
    For Each cell In rng
        Filename = cell.Value
        If Len(Filename) < 5 Then GoTo skip
        
        'download the file to the temp folder and return the path
        tempPath = DownLoadedImagePath(Filename)
        
        Set theShape = ActiveSheet.Shapes.AddPicture( _
            Filename:=tempPath, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, _
            Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
        
        With theShape
            .LockAspectRatio = msoTrue
            .Top = cell.Top + 1
            .Left = cell.Left + 1
            .Height = cell.Height - 2
            '.Width = cell.Width - 2
            .Placement = xlMoveAndSize
        End With
        ' Get rid of the
        'cell.ClearContents
'isnill:
        'Set theShape = Nothing
        'Range("A2").Select

skip:
    Next
    Application.ScreenUpdating = True

    Debug.Print "Done " & Now

End Sub

'download content from `url` to a temp file and return the temp file path
Function DownLoadedImagePath(url As String) As String
    Dim Data() As Byte, tempPath As String, fNum As Long
    With CreateObject("WinHTTP.WinHTTPrequest.5.1")
        .Open "GET", url, False
        .send
        Data = .responseBody
    End With
    fNum = FreeFile
    tempPath = getTempPath()
    Open tempPath For Binary Access Write As #fNum
    Put #fNum, 1, Data
    Close #fNum
    DownLoadedImagePath = tempPath
End Function

'return a temporary file path
Function getTempPath() As String
    With CreateObject("scripting.filesystemobject")
        getTempPath = .GetSpecialFolder(2) & "\" & .GetTempName
    End With
End Function