以编程方式将Excel中的宏指定给范围内的多个形状

这对一些人来说可能非常容易，但对我来说肯定不是。我在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

---

将图片变暗为形状

（从对象更改）。然后在

Sub-FitPic（）

中的

FitIndividualPic

行后立即添加以下代码：

Pic.OnAction=“ClickResizeImage”

要清楚，这应该是您的新

FitPic（）

：

---

伟大的FitPic的代码刚刚好用！但是，对于AddPicFromFile，在Excel的VBA编辑器中，

设置新PIC…

和

高度：=42之间的所有文本都显示为红色。尝试运行宏时会出现编译错误：语法错误。或者，可以让FitPic处理这两个操作，如果选择空单元格，它将从桌面添加图片，或者如果选择图片，它将以现有方式运行。想想看，这听起来是个更好的主意。@donmega187，你为什么不接受这个答案？您添加了AddPicFromFile。是的，我编辑了添加您的答案，但代码不起作用。隐马尔可夫模型。。。如果这违反了程序或其他什么，我很抱歉。在这种情况下，我想我只需要为AddPicFromFile添加另一个问题，这样我现在就可以接受FitPic的完美答案了。@donmega187，这要好得多，这样我们就可以详细了解AddPicFromFile的问题，而这不在您的问题中。
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