Programmatically assign macro in Excel to a picture added from file

Question

I have an inventory worksheet inside inventory.xlsm workbook with lots of product pictures. I use a macro called AddPicFromFile() to add a picture from desktop and fit it into the cell. 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.

Sub AddPicFromFile()

Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double

Set ws = ActiveSheet
imagePath = "C:\Users\Secret\Desktop\untitled-1.jpg"
imgLeft = ActiveCell.Left
imgTop = ActiveCell.Top

'Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
    Filename:=imagePath, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=imgLeft + 0.75, _
    Top:=imgTop + 0.75, _
    Width:=42, _
    Height:=42

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

I tried adding Selection.OnAction = "ClickResizeImage" to the code but it comes up with Run-time error '438': Object doesn't support this property or method. One part of the problem is AddPicFromFile doesn't select the shape and that's required by ClickResizeImage to work, as it does work as standalone module. I just want to combine them into one macro basically.

Answer 1

This will assign a macro to a Shape :

Sub stepup()
    Dim s As Shape
    Set s = ActiveSheet.Shapes(1)
    s.OnAction = "ClickResizeImage"
End Sub

Answer 2

将此代码添加到您的AddPicFromFile代码的末尾：

ws.Shapes(ActiveSheet.Shapes.Count).OnAction = "ClickResizeImage"