将图片插入 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

我遇到的问题是，我似乎无法保持图片的纵横比，同时确保它们不超过 space 的范围他们应该适合 Excel 形式。这些图片也都是屏幕截图，因此它们的形状和大小存在很大差异。

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

这将最大化 space 的图像大小而不扭曲它。

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，要么设置宽度, 或高度或两者都设置但根据纵横比拉伸。

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

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

将图片插入 Excel 并保持纵横比不超过 VBA 的尺寸

Insert picture into Excel and keep aspect ratio without exceeding dimensions with VBA

excel

ms-access

vba

ms-access-2007