Insert image into Excel and keep aspect ratio without oversizing with VBA
I am exporting data from an Access database to an Excel report, and part of what needs to be included in the report are images that match the data. Images are saved in a shared file and inserted into the Excel file like this:
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 problem I am running into is that I cannot keep the proportions of the images and make sure that at the same time they do not go beyond the bounds of the space that they should fit the Excel form. The pictures also have all the screenshots, so there is a lot of variation in their shape and size.
Basically what I want to do is something like grabbing the corner of the image and expanding it until it touches either the left or the bottom of the range it should be placed in.
This will maximize the size of the image for the space without distorting it.
source to share
Basically what I want to do is something like grabbing the corner of the image and expanding it until it touches either the left or the bottom of the range it should be placed in.
Then you must first find the size of the range (width and height) and then find which of the width and height of the image, expand, touch those borders first, then set LockAspectRatio = True
and either set the width or height, or set both but stretched according to the ratio parties.
The following scale scales the image to the 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
source to share