Help with resizing images using VBA.

Cruiser69

New Member
Joined
Mar 12, 2018
Messages
34
Office Version
  1. 365
Platform
  1. Windows
Hi all

Hi all

I use the code below to insert images into an excel sheet
It works well, but I would like to make the height of the images fit just inside the cell as sometimes the images overlap and causes a problem when creating a PDF from it

Code:
[FONT=Calibri][SIZE=3][COLOR=#000000]Sub Insert_Pictures()
[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]Dim PicList() As Variant[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim PicFormat AsString[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim rng As Range[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim sShape AsShape[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim MaxWidth#[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    On Error ResumeNext[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    PicList =Application.GetOpenFilename(PicFormat, MultiSelect:=True)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    xColIndex =Application.ActiveCell.Column[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    IfIsArray(PicList) Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        xRowIndex =Application.ActiveCell.Row[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        For lLoop =LBound(PicList) To UBound(PicList)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            Set rng =Cells(xRowIndex, xColIndex)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            WithActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, rng.Left,rng.Top, -1, -1)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]               .LockAspectRatio = True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]               .Height = 480 * 3 / 4[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]               rng.RowHeight = .Height[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                IfMaxWidth < .Width Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                    MaxWidth = .Width[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                End If[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            End With[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            xRowIndex= xRowIndex + 1[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Next[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]       rng.ColumnWidth = MaxWidth / rng.Width * rng.ColumnWidth[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]       rng.ColumnWidth = MaxWidth / rng.Width * rng.ColumnWidth[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        rng.ColumnWidth= MaxWidth / rng.Width * rng.ColumnWidth[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        For EachsShape In ActiveSheet.Shapes[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           sShape.Left = MaxWidth / 2 - sShape.Width / 2[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Next[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    End If[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]End Sub
[/COLOR][/SIZE][/FONT]


If there is a way to do this I would be grateful.

Regards,

Graham
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,796
Office Version
  1. 2010
Platform
  1. Windows
Try this:

Code:
            With ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, rng.Left,rng.Top, -1, -1)               .LockAspectRatio = True

        If .Height > rng.Height then
           .RowHeight = rng.Height
        Elseif .Width > rng.Width then
           ColumnWidth = rng.Width
        End If

        If .Height > rng.Height then
           .RowHeight = rng.Height
        Elseif .Width > rng.Width then
           ColumnWidth = rng.Width
        End If
[COLOR=#008000]
'               .Height = 480 * 3 / 4
'               rng.RowHeight = .Height
'                IfMaxWidth < .Width Then
'                    MaxWidth = .Width
'                End If[/COLOR]
           End With
           xRowIndex= xRowIndex + 1
       Next
[COLOR=#008000]'       rng.ColumnWidth = MaxWidth / rng.Width * rng.ColumnWidth
'      rng.ColumnWidth = MaxWidth / rng.Width * rng.ColumnWidth
'       rng.ColumnWidth= MaxWidth / rng.Width * rng.ColumnWidth
'       For EachsShape In ActiveSheet.Shapes
'          sShape.Left = MaxWidth / 2 - sShape.Width / 2
'       Next[/COLOR]
   End If
 

Cruiser69

New Member
Joined
Mar 12, 2018
Messages
34
Office Version
  1. 365
Platform
  1. Windows
Hi, sorry that does not work.
It just makes the pics very large and they overlap.
I forgot to add that I make the row height 409 as I add text below the pics

Code:
Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    Dim MaxWidth#
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    xColIndex = Application.ActiveCell.Column
    If IsArray(PicList) Then
        xRowIndex = Application.ActiveCell.Row
        For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            With ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)
                .LockAspectRatio = True
                .Height = 480 * 3 / 4
                Rng.RowHeight = .Height
                If MaxWidth < .Width Then
                    MaxWidth = .Width
                End If
            End With
            xRowIndex = xRowIndex + 1
        Next
        Rng.ColumnWidth = MaxWidth / Rng.Width * Rng.ColumnWidth
        Rng.ColumnWidth = MaxWidth / Rng.Width * Rng.ColumnWidth
        Rng.ColumnWidth = MaxWidth / Rng.Width * Rng.ColumnWidth
        For Each sShape In ActiveSheet.Shapes
            sShape.Left = MaxWidth / 2 - sShape.Width / 2
        Next
    End If
    Selection.RowHeight = 409

I jut want the images to fit just inside the cell border
 

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,796
Office Version
  1. 2010
Platform
  1. Windows
Try this:

Code:
            With ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, rng.Left,rng.Top, -1, -1)               .LockAspectRatio = True

        If .Height > rng.Height then
           .Height = rng.Height
        Elseif .Width > rng.Width then
           .Width = rng.Width
        End If

        If .Height > rng.Height then
           .Height = rng.Height
        Elseif .Width > rng.Width then
           .Width = rng.Width
        End If
[COLOR=#008000]
'               .Height = 480 * 3 / 4
'               rng.RowHeight = .Height
'                IfMaxWidth < .Width Then
'                    MaxWidth = .Width
'                End If[/COLOR]
           End With
           xRowIndex= xRowIndex + 1
       Next
[COLOR=#008000]'       rng.ColumnWidth = MaxWidth / rng.Width * rng.ColumnWidth
'      rng.ColumnWidth = MaxWidth / rng.Width * rng.ColumnWidth
'       rng.ColumnWidth= MaxWidth / rng.Width * rng.ColumnWidth
'       For EachsShape In ActiveSheet.Shapes
'          sShape.Left = MaxWidth / 2 - sShape.Width / 2
'       Next[/COLOR]
   End If
 

Cruiser69

New Member
Joined
Mar 12, 2018
Messages
34
Office Version
  1. 365
Platform
  1. Windows
Hi
That worked.
Thanks for your help.

Regards,

Graham
 

Watch MrExcel Video

Forum statistics

Threads
1,119,063
Messages
5,575,886
Members
412,689
Latest member
nhsmedic
Top