Application.Caller for Shapes with duplicate names

Question

I am using Application.Caller in a subroutine that I programmatically tied to the OnAction property of all the shapes I find on a worksheet. Application.Caller returns the name of the shape which initiated the call so that I can then obtain the appropriate shape object to process.

All of this is fine unless there is more than one shape on the sheet with the same name making it impossible to determine which is the caller. Excel manages the naming when inserting, copying and pasting shapes manually in a worksheet but these worksheets are populated through external apps which can cause this naming redundancy.

I am currently managing this by first scanning and renaming the redundant shapes so that I can identify them with the Application.Caller function. However, I do not want to rename them.

Code I've tried:

Set objShape = Application.Caller - unfortunately does not work

iShapeID = Application.Caller.ID - unfortunately does not work

iShapeID = ActiveSheet.Shapes(Application.Caller).ID - works but does not identify the correct caller when there are shapes with the same name

So, my question is: How can I obtain the proper Application.Caller shape object when there are redundantly named shapes on the worksheet?.

Put another way: Is there a way to cast the Application.Caller to a shape object without using the name of the shape returned by Application.Caller ideally using the ID property of the shape?

Answer 1

As Robin said, I don't think it's possible to specify a shape object without the string name reference. What I did and worked out in my case, was to rename all shapes every time the number of shapes is higher than the previous counting in the worksheet. This way you can ensure a unique name for each shape every time a new shape is added. For that, I had to use the Worksheet_Change event.

' Global variable to check if the number of shapes in the worksheet has been changed
Public lastShapeCounting As Integer

Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    ' Set the worksheet
    Set ws = ActiveSheet
    countShapes = ws.Shapes.Count
    'Checks if new shapes has been added. If not, do not iterate (improve performance)
    If lastShapeCounting < countShapes Then
        Dim shape As shape
        uniqueShapeID = 0
        ' Rename all shapes to make sure every shape has an unique name.
        For Each shape In ws.Shapes
            uniqueShapeID = uniqueShapeID + 1
            shape.Name = "Shape_" & uniqueShapeID
        Next
    End If
    'Update global variable to avoid iterating every time
    lastShapeCounting = countShapes
End Sub

Answer 2

Counter must be unique, also when adding shapes between.

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

Answer 3

I don't think there is a an alternative for Application.Caller to return the ID property of the Shape or some other 'trick' to achieve what you want.

The work-around is to ensure that all your Shapes have unique names. If you have a sheet of names with duplicates you can quickly make them unique by re-naming them to preserve the original duplicate but add a suffix e.g. _1 to make them unique.

The sub could work like this (using a Dictionary to track the suffix value):

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

Here's the full test code that creates your issue and uses MakeShapeNamesUnique to work-around the problem. If you want to try it out, put it in a blank workbook because it will delete shapes out of the sheet before it starts:

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