代码不会从某些 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

URL的

    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

您将需要使用 On Error Resume Next，但仅用于插入图片的单个语句。你应该去掉 Select。 Pictures.Insert-方法 returns 对插入图像的引用，将其分配给一个变量并使用该变量。

此外，我建议拆分您的代码并创建一个将一个图像插入单元格的例程。从循环中调用此例程。我已经将它实现为一个函数 returns True 如果它成功了，如果它 returns False.[= 则由你决定是否要做某事。 17=]

Function TryInsertImg(filename As String, cell As Range) As Boolean
    Dim p As Picture
    On Error Resume Next
    Set p = cell.Parent.Pictures.Insert(filename)
    If Err.Number > 0 Then Debug.Print "Couldn't insert image " & Err.Number & "-" & Err.Description
    On Error GoTo 0
    If p Is Nothing Then
        Exit Function
    End If
        
    Dim theShape As Shape
    Set theShape = p.ShapeRange.Item(1)
    
    With theShape
        .LockAspectRatio = msoFalse
        .Width = 20
        .Height = 20
        .Top = cell.Top + (cell.Height - .Height) / 2
        .Left = cell.Left + (cell.Width - .Width) / 2
    End With
    TryInsertImg = True
End Function

您的调用例程可能如下所示：

For Each cell In rng
    Filename = cell
    If InStr(UCase(Filename), "JPG") > 0 Then   '<--- ONLY USES JPG'S
        xCol = cell.Column + 1
        Set xRg = Cells(cell.Row, xCol)
        If Not TryInsertImg(filename, xRg) then 
            xRg = "(error loading image)"
        End If
    End If
Next cell

Answer 2

试试下面的代码，它将 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

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

Code does not Extract the Images from some URL

url

excel

vba

image

extract