Programmatically assign macro in Excel to multiple shapes in a range

Question

This is probably super easy for some, but certainly not for me. I have an inventory worksheet inside inventory.xlsm workbook with lots of product pictures. I use a macro called FitPic() to fit them into the cells. I require that when the macro is run it would do its usual stuff, but also assign a macro called ClickResizeImage() to the picture shape.

Public Sub FitPic()
    On Error GoTo NOT_SHAPE
    Dim Pic As Object
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single

    If TypeName(Selection) = "DrawingObjects" Then
        For Each Pic In Selection.ShapeRange
            FitIndividualPic Pic
        Next Pic
    Else
        FitIndividualPic Selection
    End If
Exit Sub
NOT_SHAPE:
    MsgBox "Select a picture before running this macro." & " Num" & Count
 End Sub

 Public Sub FitIndividualPic(Pic As Object)
    Dim Gap As Single
    Gap = 0.75
        With Pic
                Pic.Placement = xlMoveAndSize
            PicWtoHRatio = (.Width / .Height)
        End With
        With Pic.TopLeftCell
            CellWtoHRatio = .Width / .RowHeight
        End With
        Select Case PicWtoHRatio / CellWtoHRatio
        Case Is > 1
        With Pic
            .Width = .TopLeftCell.Width - Gap
            .Height = .Width / PicWtoHRatio - Gap
        End With
        Case Else
        With Pic
            .Height = .TopLeftCell.RowHeight - Gap
            .Width = .Height * PicWtoHRatio - Gap
        End With
        End Select
        With Pic
            .Top = .TopLeftCell.Top + Gap
            .Left = .TopLeftCell.Left + Gap
        End With
 End Sub

And this here is the ClickResizeImage() which of course works fine as a standalone.

Sub ClickResizeImage()
Dim shp As Shape
    Dim big As Single, small As Single

    Dim shpDouH As Double, shpDouOriH As Double
    big = 8
    small = 1
    On Error Resume Next
    Set shp = ActiveSheet.Shapes(Application.Caller)
    With shp
        shpDouH = .Height
        .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        shpDouOriH = .Height

        If Round(shpDouH / shpDouOriH, 2) = big Then
            .ScaleHeight small, msoTrue, msoScaleFromTopLeft
            .ScaleWidth small, msoTrue, msoScaleFromTopLeft
            .ZOrder msoSendToBack
        Else
            .ScaleHeight big, msoTrue, msoScaleFromTopLeft
            .ScaleWidth big, msoTrue, msoScaleFromTopLeft
            .ZOrder msoBringToFront
        End If
    End With

End Sub

user_5166387 · Answer

Dim Pic As Shape (change from Object). Then add the following code immediately after the line FitIndividualPic Pic in Sub FitPic(): Pic.OnAction = "ClickResizeImage".

To be clear, this should be your new FitPic():

Public Sub FitPic()
    On Error GoTo NOT_SHAPE
    Dim Pic As Shape
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single

    If TypeName(Selection) = "DrawingObjects" Then
        For Each Pic In Selection.ShapeRange
            FitIndividualPic Pic
            Pic.OnAction = "ClickResizeImage"
        Next Pic
    Else
        FitIndividualPic Selection
        Selection.OnAction = "ClickResizeImage" 'also assigns the macro to the Selection
    End If
Exit Sub
NOT_SHAPE:
    MsgBox "Select a picture before running this macro." & " Num" & Count
 End Sub

Programmatically assign macro in Excel to multiple shapes in a range

1 Answers