excel - 具有重复名称的形状的 Application.Caller

Question

我在一个子例程中使用 Application.Caller，我以编程方式将其绑定(bind)到我在工作表上找到的所有形状的 OnAction 属性。 Application.Caller 返回启动调用的形状的名称，以便我可以获取适当的形状对象进行处理。

所有这一切都很好，除非工作表上有多个形状具有相同的名称，从而无法确定哪个是调用者。在工作表中手动插入、复制和粘贴形状时，Excel 会管理命名，但这些工作表是通过外部应用程序填充的，这可能会导致这种命名冗余。

我目前通过首先扫描和重命名冗余形状来管理它，以便我可以使用 Application.Caller 函数识别它们。但是，我不想重命名它们。

我试过的代码:

Set objShape = Application.Caller - 不幸的是不起作用

iShapeID = Application.Caller.ID - 不幸的是不起作用

iShapeID = ActiveSheet.Shapes(Application.Caller).ID - 可以工作，但当存在具有相同名称的形状时无法识别正确的调用者

因此，我的问题是:当工作表上存在重复命名的形状时，我如何才能获得正确的 Application.Caller 形状对象？。

换句话说:有没有办法在不使用 Application.Caller 返回的形状名称的情况下将 Application.Caller 转换为形状对象，最好使用形状的 ID 属性？

Answer 1

我认为 Application.Caller 没有替代方案来返回 Shape 的 ID 属性或其他一些 '技巧'来实现你想要的。

解决方法是确保您所有的 Shape 都具有唯一的名称。如果您有一张包含重复名称的工作表，您可以通过重命名它们来快速使它们唯一，以保留原始重复项，但添加后缀，例如_1 使它们独一无二。

sub 可以像这样工作(使用 Dictionary 来跟踪后缀值):

Sub MakeShapeNamesUnique(ws As Worksheet)

    Dim shp As Shape
    Dim dic As Object
    Dim lng As Long

    Set dic = CreateObject("Scripting.Dictionary")

    'iterate shapes
    For Each shp In ws.Shapes
        ' does shape name exist ?
        If Not dic.Exists(shp.Name) Then
            ' add name to dictionary if not exists with counter of 0
            dic.Add shp.Name, 0
        Else
            ' found a duplicate
            ' increment counter
            dic(shp.Name) = dic(shp.Name) + 1
            ' rename shape with suffix indicating dupe index
            shp.Name = shp.Name & "_" & dic(shp.Name)
        End If
    Next shp

    ' job done - clean up the dictionary
    Set dic = Nothing

End Sub

这是创建您的问题并使用 MakeShapeNamesUnique 解决问题的完整测试代码。如果您想尝试一下，请将其放在空白工作簿中，因为它会在开始之前从工作表中删除形状:

Option Explicit

Sub Test1()

    Dim ws As Worksheet
    Dim shp As Shape

    ' reset shapes
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    ' add shape
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 10, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 160, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 160, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 160, 100, 100)
        .Name = "Foo3"
        .OnAction = "ShapeAction"
    End With

    ' uniqueify shape names - comment out to replicate OP problem
    MakeShapeNamesUnique ws

End Sub

Sub ShapeAction()

    Dim shp As Shape

    Set shp = Sheet1.Shapes(Application.Caller)
    MsgBox " My name is: " & shp.Name & " and my ID is: " & shp.ID

End Sub

Sub MakeShapeNamesUnique(ws As Worksheet)

    Dim shp As Shape
    Dim dic As Object
    Dim lng As Long

    Set dic = CreateObject("Scripting.Dictionary")

    'iterate shapes
    For Each shp In ws.Shapes
        ' does shape name exist ?
        If Not dic.Exists(shp.Name) Then
            ' add name to dictionary if not exists with counter of 0
            dic.Add shp.Name, 0
        Else
            ' found a duplicate
            ' increment counter
            dic(shp.Name) = dic(shp.Name) + 1
            ' rename shape with suffix indicating dupe index
            shp.Name = shp.Name & "_" & dic(shp.Name)
        End If
    Next shp

    ' job done - clean up the dictionary
    Set dic = Nothing

End Sub