Application.Caller for Shapes with duplicate names - excel

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

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

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