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

将图片插入Excel并保持纵横比不超过维度

1 个答案: