Импортируйте URL в формате jpg, а размер по ширине столбца и высоте строки изображения

Question

Я работаю над загрузкой около 8k файлов jpg из net. URL для файлов находится в столбце B, и я хочу вывести фактическое изображение в столбце C. У меня есть некоторый код, который я исказил вместе, чтобы сделать загрузку, но изображения приходят маленькими. Я хочу, чтобы они пришли в оригинальном размере. Итак, я бы хотел определить, какой самый большой файл jpg, и сделать так, чтобы высота строки и ширина столбца соответствовали ему. Вот код, который у меня есть:

Sub Test2()
Dim Pic As Picture
Dim SrcRange As Range
Dim LastRowA As Long

    LastRowA = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

    Set SrcRange = ActiveSheet.Range(Cells(2, 1), Cells(LastRowA, 1))

    SrcRange.Rows().RowHeight = ActiveSheet.Columns(3).Width * 2

    For Each cell In SrcRange.Cells
        With cell
            Set Pic = .Parent.Pictures.Insert(.Value)
            With .Offset(, 1)
                Pic.Top = .Top
                Pic.Left = .Left
                Pic.Height = .Height
                Pic.Width = .Width
                Pic.Border.Color = vbRed
            End With
        End With
    Next
End Sub

Как всегда, любая помощь будет принята с благодарностью. Прошло около 5 лет с тех пор, как я занимался программированием Excel VBA. Я немного ржавый. Я использую Excel 2016.

Answer 1

Установите для формата изображения значение false.

Pic.ShapeRange.LockAspectRatio = msoFalse

В вашем коде ..

For Each cell In SrcRange.Cells
    With cell
        Set Pic = .Parent.Pictures.Insert(.Value)
        Pic.ShapeRange.LockAspectRatio = msoFalse '<~~ set LockAspetRatio to false
        With .Offset(, 1)
            Pic.Top = .Top
            Pic.Left = .Left
            Pic.Height = .Height
            Pic.Width = .Width
            Pic.Border.Color = vbRed
        End With
    End With
Next

End Sub

В приведенном выше методе изображение не сохраняется как файл Excel, устанавливается только ссылка. Чтобы сохранить изображение в файл Excel, выполните следующие действия:

Sub Test2()
Dim Pic As Picture
Dim SrcRange As Range
Dim LastRowA As Long
Dim l As Single, t As Single, w As Single, h As Single
Dim cell As Range

    LastRowA = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row

    Set SrcRange = ActiveSheet.Range(Cells(2, 1), Cells(LastRowA, 1))

    SrcRange.Rows().RowHeight = ActiveSheet.Columns(3).Width * 2

    For Each cell In SrcRange.Cells
        With cell
            t = .Top
            l = .Left
            w = .Width
            h = .Height
            Set shp = ActiveSheet.Shapes.AddPicture(.Value, msoCTrue, msoCTrue, l, t, w, h)
        End With
    Next
End Sub