将图片插入Excel，并保持宽高比不超过维度与VBA
我将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表格的范围的边界。 图片也是截图，所以它们的形状和大小有很大的变化。
基本上我想要做的是抓住图片的angular落，扩大它，直到它触及的范围的左边或底部的边缘应该被放置在。
这将最大化图像的大小，而不会使图像变形。
基本上我想要做的是抓住图片的angular落，扩大它，直到它触及的范围的左边或底部的边缘应该被放置在。
然后，你必须先find范围的大小（宽度和高度），然后find图片的宽度和高度，扩大，首先触摸这些边界，然后设置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