Search code examples
excelvba

Insert photos into cells without changing the aspect ratio

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 center aligned inside a rectangular cell. Different image file formats must be acceptable.

I expect a centered image with 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:
1

I found code online. I can click on a cell, 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 in the cell without the cell size changing.

The problem is that it stretches the image to fill that active cell.

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

Image of the spreadsheet. The single button will be frozen in the first two rows.
2

Current result. The image gets stretched to fill the different sized cells.
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