批量插入图片到单元格的纵横比问题

china047

各位老师, 如何将下面的代码改为: 插入的图片高度等于单元格的高度, 图片宽度按比例缩放, 先谢过老师了!

Sub insertPic()
    Dim rng As Range, FilPath$, ML, MT, MW, MH, shp As Shape, Myr&, i%
    On Error Resume Next

    Sheet1.Activate
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoAutoShape Then
            shp.Delete
        End If
    Next


    With Sheet1

        For i = 2 To .Range("a65536").End(xlUp).Row

            FilPath = ThisWorkbook.Path & "\图片\" & Cells(i, 2).Value & ".jpg" 'ThisWorkbook.Path
             If Dir(FilPath) <> "" Then
             Set rng = .Cells(i, 3)

                With rng

                     ML = .Left + 1
                     MT = .Top + 1
                     MW = .Width - 1
                     MH = .Height - 1
                     ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
                     Selection.ShapeRange.Fill.UserPicture FilPath
                     Selection.ShapeRange.Line.Visible = msoFalse
                     Selection.Placement = xlMoveAndSize


                 End With
             End If
        Next
        .Cells(1, 1).Select
    End With
   If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
End Sub

liulang0808

https://club.excelhome.net/thread-1441877-1-1.html
参考这个，先将纵横比给锁定了

zhujq99

在论坛里看到的代码，希望对你有用
Sub 图片自适应单元格()
Dim Pic As Object
Dim rng As Range
For Each Pic In ActiveSheet.Shapes
    Set rng = Pic.TopLeftCell
        With Pic
             If .Height / .Width > rng.Height / rng.Width Then
             .Height = rng.Height - 5
             .Top = rng.Top + 2.5
             .Left = rng.Left + (rng.Width - .Width) / 2
             .Placement = xlMoveAndSize
         Else
             .Width = rng.Width - 5
             .Left = rng.Left + 2.5
             .Top = rng.Top + (rng.Height - .Height) / 2
             .Placement = xlMoveAndSize
        End If
  End With
Next
End Sub

china047

liulang0808 发表于 2021-12-31 18:19
https://club.excelhome.net/thread-1441877-1-1.html
参考这个，先将纵横比给锁定了

已解决，应该用了自选图形的原因

china047

zhujq99 发表于 2021-12-31 19:27
在论坛里看到的代码，希望对你有用
Sub 图片自适应单元格()
Dim Pic As Object

图片居中这个算法不错