Question

我在子程序中使用OnAction，我以编程方式绑定到工作表上找到的所有形状的Application.Caller属性。 Application.Caller返回启动调用的形状的名称，以便我可以获得要处理的相应形状对象。

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

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

我试过的代码：

iShapeID = Application.Caller.ID - 遗憾的是无效

iShapeID = ActiveSheet.Shapes(Application.Caller).ID - 遗憾的是无效

Button - 当有同名形状时，无法识别正确的来电者

所以，我的问题是： 当工作表上有冗余命名的形状时，如何获得正确的Application.Caller形状对象？ 。

换句话说： 有没有办法将Application.Caller强制转换为形状对象，而不使用Application.Caller返回的形状名称，理想情况下使用形状的ID属性？

Answer 1

我认为Application.Caller还有一个替代方法可以返回ID或其他一些诡计的Shape属性。实现你想要的。

解决方法是确保您的所有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

Answer 2

在之间添加形状时，计数器也必须唯一。

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 (must be unique)
            Do
                dic(shp.Name) = dic(shp.Name) + 1
            Loop Until Not dic.Exists(shp.Name & "_" & dic(shp.Name))
            ' 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

具有重复名称的Shapes的Application.Caller

2 个答案: