以编程方式将Excel中的宏分配给一个范围内的多个形状

Question

对于某些人来说，这可能超级容易，但对我而言绝对不是。 我在stock.xlsm工作簿中有一个库存工作表，其中包含许多产品图片。 我使用一个名为FitPic()的宏将它们放入单元格中。 我要求在运行宏时，它将执行其通常的工作，但还要将一个名为ClickResizeImage()的宏分配给图片形状。

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

这是ClickResizeImage() ，当然，它可以独立运行。

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

Answer 1

Dim Pic As Shape （从对象更改）。 然后在Sub FitPic() FitIndividualPic Pic行之后立即添加以下代码： Pic.OnAction = "ClickResizeImage" 。

要明确的是，这应该是您的新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