excel - 将 URL 导入为 jpg 并调整图像的最大列宽和行高

Question

我正在从网上下载大约 8k jpg 文件。文件的 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

与往常一样，我们将不胜感激任何帮助。自从我完成任何 excel vba 编码以来已经大约 5 年了。我有点生疏了。我正在运行 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

结束子

上述方法中，并没有将图片保存为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