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（从Object更改）。然后在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

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

1 个答案: