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

Question

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

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.

Are you setting this to false on purpose? `.LockAspectRatio = msoFalse` — nicolaus-hee, Jun 20 '15 at 07:56

score 5 · Accepted Answer · answered Jun 20 '15 at 17:14

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.

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

Exactly what I was looking for. – 110SidedHexagon Jun 22 '15 at 13:56 — 110SidedHexagon, Jun 22 '15 at 13:56

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

1 Answers1

Linked