Как сохранить исходный размер изображения с помощью vba?

Question

В основном я пишу код, который захватывает URL-адреса изображений из списка и выводит их размер в ячейке. Он работает для некоторых ссылок, но не для всех. Может ли кто-нибудь сказать мне, почему это так?

Dim MyPic As Shape 
Dim sht As Worksheet 

Set sht = ActiveSheet 


With sht 
    For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row 
    If .Cells(i, 2) <> "" Then 
     Set mypict = ActiveSheet.Shapes.AddPicture(.Cells(i, 2).Text, _ 
       msoFalse, msoTrue, 3, 3, -1, -1) 

     'Set mypict = ActiveSheet.Pictures.Insert(.Cells(i, 2).Text) 

     .Cells(i, 7) = mypict.Width & " x " & mypict.Height 
     mypict.Delete 
    End If 
    Next i 
End With 

С наилучшими пожеланиями,

Франциско

Answer 1

Как уже упоминалось выше, код работает для меня на URL, который дает вам сообщение об ошибке.

Однако, вот альтернативный код, который вы можете попробовать. Вы, вероятно, нужно подправить петлю/клетку, но в остальном это довольно просто:

Sub extract() 
Dim i&, lastRow& 
lastRow = Cells(Rows.Count, 1).End(xlUp).Row 

For i = 2 To lastRow 

    Dim IE As InternetExplorer 
    Dim html As HTMLDocument 

    Set IE = New InternetExplorer 
    IE.Visible = False 
    IE.navigate Cells(i, 2).Value 

    ' Wait while IE loading 
    Do While IE.Busy 
     Application.Wait DateAdd("s", 1, Now) 
    Loop 

    Set html = IE.document 

    Dim webImage As Variant 
    Set webImage = html.getElementsByTagName("img") 

    Debug.Print "Image is " & webImage(0).Width & " x " & webImage(0).Height 
    Cells(i, 2).Offset(0, 1).Value = webImage(0).Width & " x " & webImage(0).Height 
    'Cleanup 
    IE.Quit 
    Set IE = Nothing 
Next i 

End Sub 

(Заслуга @PortlandRunner для основного кода). Обратите внимание, что вы будете нуждаться в двух справочных библиотек:

1. Microsoft Internet Controls
2. Microsoft HTML объектная библиотека