excelvba

In Excel, can a button be created to insert photos into cells without distorting the original image aspect ratio?

To preface this question, I want to state that I have very little experience with code.

I am trying to create a button inside an Excel spreadsheet to insert photos from my computer into an active cell without changing the size of the cell or the aspect ratio of the photo. The photos need to be centered aligned inside a rectangular cell. Different Image file formats also must be acceptable.

It is more important to have the original image file displaying unedited than having a completely filled cell. That means that I expect to have a centered image surrounded by some blank space inside the cell, i.e. vertical aspect ratios will leave blank space on the left and right of the cell, and horizontal aspect ratios will leave blank space on the top and bottom (if it does not match the the cell exactly).

Example made in Google Sheets of the formatting I want

1

I found a code online that got me near the exact result I was hoping for, though I cannot say if it is even the best method of accomplishing this. I can click on the cell I want the photo in, click on the Insert Photo button, the file select will appear for me to grab my photo from my computer, then it inserts the image to fill the cell without the cell size changing.

The only problem is that it stretches my images to fill that active cell, and I cannot have these photos stretched in any way.

Here is the code I have for my VBA project:

Sub InsertPictureMacro()
Dim strFile As String
Dim rng As Range
Dim sh
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png; *.tif),"

strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)

If strFile = "False" Then
Else
Set rng = ActiveCell.Range("A4").MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
sh.LockAspectRatio = msoTrue
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub

Here is an image of the spreadsheet I am using, the single button will be frozen in the first 2 rows

2

Here is what the current button will result in. The original image gets stretched to fit the different sized cells to fill the entire cell

3

Solution

  • The height-to-width ratio of the image may not match the cell dimensions exactly. The key is to calculate the appropriate image shrink ratio to fit the cell while maintaining the original aspect ratio.

    Sub InsertPictureMacro()
    Dim strFile As String
    Dim rng As Range
    Dim sh, rw, rh, ratio
    Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png; *.tif),"
    strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)
    If Not strFile = "False" Then
        Set rng = ActiveCell.Range("A4").MergeArea
        With rng
            ' Insert image
            Set sh = ActiveSheet.Pictures.Insert(strFile)
            rw = .Width / sh.Width
            rh = .Height / sh.Height
            ' Get shrink ratio, apply 0.95 to get surrounded space
            ratio = IIf(rw < rh, rw, rh) * 0.95
            sh.ShapeRange.LockAspectRatio = msoTrue
            sh.Width = sh.Width * ratio
            ' position image at the center
            sh.Top = .Top + (.Height - sh.Height) / 2
            sh.Left = .Left + (.Width - sh.Width) / 2
        End With
        Set sh = Nothing
        Set rng = Nothing
    End If
End Sub