将图片插入Excel并使用VBA保持宽高比不超过尺寸 [英] Insert picture into Excel and keep aspect ratio without exceeding dimensions with VBA

问题描述

我正在将Access数据库中的数据导出到Excel报表中，该报表中需要包含的部分是与数据相对应的图片.图片存储在共享文件中，并按如下方式插入到Excel文件中:

I am exporting data from an Access database into an Excel report, and part of what needs to be included in the report are pictures corresponding to the data. The pictures are stored in a shared file and are inserted into the Excel file like so:

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表单.图片也都是屏幕截图，因此它们的形状和大小存在很大的差异.

The issue I am having is that I can't seem to be able to keep the aspect ratio of the pictures and make sure that at the same time they don't exceed the bounds of the space they are supposed to fit in the Excel form. The pictures are also all screenshots so there is a large amount of variability in their shape and size.

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

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.

这将在不失真的情况下最大化空间图像的大小.

This would maximize the size of the image for the space without distorting it.

推荐答案

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

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 或设置宽度或高度，或同时设置两者，但要根据宽高比进行拉伸.

Then you must first find the size of the range (width and height) and then find which of the picture's width and height, expanded, touches these boundaries first, then set LockAspectRatio = True and either set the width, or the height or set both but stretched according to the aspect ratio.

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

The following scales the picture to available space (adapted from your code):

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保持宽高比不超过尺寸的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！