Вставьте изображение в 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 

Проблема, которую я имею, что я не могу показаться, чтобы быть в состоянии сохранить соотношение сторон фотографии и сделать что в то же время они не превышают границ пространства, которое они должны вписывать в форму 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