Fit all selected pictures to cell size - vba macro

[Exhale2020]

Hi all,

I've been using the below macro to fit pics into the cell which they reside in.

It's working fine if I select one pic at a time but fails for more than one. I would like to save more time by making it applicable to all selected pictures to fit (and aligned) in the cell which they reside in. All of the cells could be equally sized if that helps.

Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."


End Sub

Thanks!

 

[John_w]

Try this:

Public Sub Fit_All_Selected_Pictures()

    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    
    Select Case TypeName(Selection)
    
        Case "DrawingObjects"
        
            For Each pic In Selection
                PicWtoHRatio = pic.Width / pic.Height
                CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
                Select Case PicWtoHRatio / CellWtoHRatio
                    Case Is > 1
                        With pic
                            .Width = .TopLeftCell.Width
                            .Height = .Width / PicWtoHRatio
                        End With
                    Case Else
                        With pic
                            .Height = .TopLeftCell.RowHeight
                            .Width = .Height * PicWtoHRatio
                        End With
                End Select
                With pic
                    .Top = .TopLeftCell.Top
                    .Left = .TopLeftCell.Left
                End With
            Next
            
        Case "Picture"
    
            Set pic = Selection
            PicWtoHRatio = pic.Width / pic.Height
            CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
            Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    With pic
                        .Width = .TopLeftCell.Width
                        .Height = .Width / PicWtoHRatio
                    End With
                Case Else
                    With pic
                        .Height = .TopLeftCell.RowHeight
                        .Width = .Height * PicWtoHRatio
                    End With
            End Select
            With pic
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
   
        Case Else
        
            MsgBox "Select 1 or multiple pictures before running this macro."
            
    End Select
    
End Sub

 

[Exhale2020]

Try this:

Public Sub Fit_All_Selected_Pictures()

    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    
    Select Case TypeName(Selection)
    
        Case "DrawingObjects"
        
            For Each pic In Selection
                PicWtoHRatio = pic.Width / pic.Height
                CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
                Select Case PicWtoHRatio / CellWtoHRatio
                    Case Is > 1
                        With pic
                            .Width = .TopLeftCell.Width
                            .Height = .Width / PicWtoHRatio
                        End With
                    Case Else
                        With pic
                            .Height = .TopLeftCell.RowHeight
                            .Width = .Height * PicWtoHRatio
                        End With
                End Select
                With pic
                    .Top = .TopLeftCell.Top
                    .Left = .TopLeftCell.Left
                End With
            Next
            
        Case "Picture"
    
            Set pic = Selection
            PicWtoHRatio = pic.Width / pic.Height
            CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
            Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    With pic
                        .Width = .TopLeftCell.Width
                        .Height = .Width / PicWtoHRatio
                    End With
                Case Else
                    With pic
                        .Height = .TopLeftCell.RowHeight
                        .Width = .Height * PicWtoHRatio
                    End With
            End Select
            With pic
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
   
        Case Else
        
            MsgBox "Select 1 or multiple pictures before running this macro."
            
    End Select
    
End Sub

Works perfectly thanks John