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

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

Basically what I want to do is something to the effect of grabbing the corner of the picture and expanding it until it touches either the left or bottom edge of the range it is supposed to be placed in.

那么你必须首先找到范围的大小(宽度和高度)，然后找到展开后图片的宽度和高度中的哪一个首先接触到这些边界，然后设置LockAspectRatio = True和其中之一设置宽度或高度或同时设置但根据纵横比拉伸(stretch)。

以下将图片缩放到可用空间(根据您的代码改编):

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