使用VBA将图片插入Excel并保持宽高比不超过尺寸

我正在将Access数据库中的数据导出到Excel报告中，报告中需要包含的部分内容是与数据对应的图片。图片存储在共享文件中并插入到 Excel 文件中，如下所示：

Dim P As Object
Dim xlApp As Excel.Application
Dim WB As Workbook

Set xlApp = New Excel.Application

With xlApp
     .Visible = False
     .DisplayAlerts = False
End With

Set WB = xlApp.Workbooks.Open(FilePath, , True)

Set P = xlApp.Sheets(1).Pictures.Insert(PicPath) 'Insert picture
With P
     With .ShapeRange
          .LockAspectRatio = msoFalse
          .Width = 375
          .Height = 260
     End With
     .Left = xlApp.Sheets(1).cells(y, x).Left
     .Top = xlApp.Sheets(1).cells(y, x).Top
     .Placement = 1
     .PrintObject = True
End With

WB.SaveAs FileName:= NewName, CreateBackup:=False 
WB.Close SaveChanges:=True

xlApp.DisplayAlerts = True
xlApp.Application.Quit

我遇到的问题是，我似乎无法保持图片的纵横比，同时确保它们不会超出 Excel 表单中应容纳的空间范围。这些图片也都是屏幕截图，因此它们的形状和大小存在很大的差异。

基本上我想做的是抓住图片的一角并将其扩展，直到它触及它应该放置的范围的左边缘或下边缘。

这将最大化空间图像的尺寸而不扭曲它。

基本上我想做的是抓住图片的一角并将其扩展，直到它触及它应该放置的范围的左边缘或下边缘。

那么首先要找到范围的大小（宽度和高度），然后找到图片的宽度和高度，展开后，哪个先接触到这些边界，然后设置LockAspectRatio = True并设置宽度或高度，或设置两者但根据纵横比拉伸。

以下将图片缩放到可用空间（根据您的代码改编）：

Sub PicTest()

    Dim P As Object
    Dim WB As Workbook
    Dim l, r, t, b
    Dim w, h        ' width and height of range into which to fit the picture
    Dim aspect      ' aspect ratio of inserted picture

    l = 2: r = 4    ' co-ordinates of top-left cell
    t = 2: b = 8    ' co-ordinates of bottom-right cell

    Set WB = ActiveWorkbook

    Set P = ActiveWorkbook.Sheets(1).Pictures.Insert(PicPath) 'Insert picture
    With P
         With .ShapeRange
              .LockAspectRatio = msoTrue    ' lock the aspect ratio (do not distort picture)
              aspect = .Width / .Height     ' calculate aspect ratio of picture
              .Left = Cells(t, l).Left      ' left placement of picture
              .Top = Cells(t, l).Top        ' top left placement of picture
         End With
         w = Cells(b, r).Left + Cells(b, r).Width - Cells(t, l).Left    ' width of cell range
         h = Cells(b, r).Top + Cells(b, r).Height - Cells(t, l).Top     ' height of cell range
         If (w / h < aspect) Then
            .ShapeRange.Width = w           ' scale picture to available width
         Else
            .ShapeRange.Height = h          ' scale picture to available height
         End If
         .Placement = 1
    End With

End Sub