excel - 代码不会从某些 URL 中提取图像

Question

我一直在使用此代码，它适用于某些 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 rng = ActiveSheet.Range("A1:A3000")   ' <---- ADJUST THIS
    For Each cell In rng
        Filename = cell
        If InStr(UCase(Filename), "JPG") > 0 Then   ' <--- USES JPG ONLY
            ActiveSheet.Pictures.Insert(Filename).Select
            Set theShape = Selection.ShapeRange.Item(1)
            If theShape Is Nothing Then GoTo isnill
            xCol = cell.Column + 1
            Set xRg = Cells(cell.Row, xCol)
            With theShape
                .LockAspectRatio = msoFalse
                .Width = 20
                .Height = 20
                .Top = xRg.Top + (xRg.Height - .Height) / 2
                .Left = xRg.Left + (xRg.Width - .Width) / 2
            End With
    isnill:
            Set theShape = Nothing
            Range("A2").Select
        End If
    Next
    Application.ScreenUpdating = True

    Debug.Print "Done " & Now

End Sub

网址的

    https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/fc310885-cd82-49cb-bc7a-aabd08531517.jpg
    https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/c6c7a645-8273-40ee-87e5-1dd385111a28.jpg
    https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/cf9f971b-6af6-4894-a2d5-c58681adb466.jpg

Answer 1

试试下面这段代码，它将 Debug.Print插入失败的 URL。适应您的需要(如果有)

Sub URLPictureInsert()
    Dim rng As Range
    Dim cell As Range
    
    Application.ScreenUpdating = False
    With ActiveSheet
        Set rng = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)   ' <---- ADJUST THIS
    End With
    
    
    For Each cell In rng
        If InStr(UCase(cell), "JPG") > 0 Then   '<--- ONLY USES JPG'S
            
            With cell.Offset(0, 1)
                On Error Resume Next
                ActiveSheet.Shapes.AddPicture cell, msoFalse, msoTrue, .Left + (.Width - 10) / 2, .Top + (.Height - 10) / 2, 20, 20
                If Err.Number = 1004 Then Debug.Print "File not found: " & cell
                On Error GoTo 0
            End With
            
        End If
    Next
    
    Application.ScreenUpdating = True
    Debug.Print "Done " & Now
End Sub