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

Question

我正在将数据从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表格的空间范围。这些图片都是屏幕截图，因此它们的形状和大小存在很大的差异。

基本上，我想做的就是抓住图片的一角并扩大它，直到它碰到应该放置的范围的左边缘或下边缘为止。

这将使空间图像的大小最大化而不会失真。

Answer 1

基本上，我想做的就是抓住图片的一角并扩大它，直到它碰到应该放置的范围的左边缘或下边缘为止。

然后，您必须首先找到范围的大小（宽度和高度），然后找到图片的宽度和高度中的哪一个，展开，首先触摸这些边界，然后设置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