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

Question

这对某些人来说可能 super 容易，但对我来说肯定不是。我在inventory.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 (从对象更改)。然后在 FitIndividualPic Pic 行之后立即添加以下代码在 Sub FitPic() :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