Help with resizing images using VBA.

[Cruiser69]

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

[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

 

[yky]

Try this:

            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]

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

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]

Try this:

            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]

Hi
That worked.
Thanks for your help.

Regards,

Graham