Copying and pasting an image in Excel locks the reference - excel

Question

Im trying to manage pictures with VBA and im having some trouble
I have an Excel spreadsheet with a picture that has a custom name "Flower"
When I copy and paste, the new image keeps the same name "Flower"
I added a macro that when I click on the picture, it tells me which picture im clicking.
Sub ImageClicked()
' ImageClicked
shapeID = ActiveSheet.Shapes(Application.Caller).ID
MsgBox (shapeID)
End Sub
But the problem is that when I click on both images, the output is the same, it shows the same ID.
When I delete the first original image and click on the second image, the showed ID changes.
Is anything that im doing wrong?
P.S. Ive already figured out that if my original shape is a "Rectangle 1", then the copied shape is "Rectangle 2" and there are no problems.

Answer 1

The issue you actually run into is that your shape names are not unique and VBA now picks the first shape it finds with that name. This is due to a bug in Excel that if you copy shapes their name is exactly the same while it should not possible to have duplicate names.
I came through this bug several times, so I wrote a code to easily fix that and ensure shape names are unique. Sometimes you are not in control over the copy/paste process because other users did that and still need unique names.
You can use the following code to ensure unique shape names in the active sheet.
Option Explicit
Public Sub MakeShapeNamesUniqueInActiveSheet()
MakeShapeNamesUnique InWorksheet:=ActiveSheet
End Sub
Public Sub MakeShapeNamesUnique(ByVal InWorksheet As Worksheet)
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
' collect all shape names and how often they occur
Dim Shp As Shape
For Each Shp In InWorksheet.Shapes
If Dict.Exists(Shp.Name) Then
Dict(Shp.Name) = Dict(Shp.Name) + 1
Else
Dict.Add Shp.Name, 1
End If
Next Shp
' check which need to be renamed (duplicates) and rename them
Dim Key As Variant
For Each Key In Dict.keys
If Dict(Key) > 1 Then ' rename only if dupicate names exist
Dim iCount As Long
iCount = 1
Dim iShp As Long
For iShp = 1 To Dict(Key)
Dim NewName As String
NewName = Key & iCount
' make sure already existing new names get jumped
Do While ShapeExists(NewName, InWorksheet)
iCount = iCount + 1
NewName = Key & iCount
Loop
InWorksheet.Shapes(Key).Name = NewName ' rename the shape
iCount = iCount + 1
Next iShp
End If
Next Key
End Sub
Public Function ShapeExists(ByVal ShapeName As String, ByVal InWorksheet As Worksheet) As Boolean
' Test if a shape exists in a worksheet
On Error Resume Next
Dim Shp As Shape
Set Shp = InWorksheet.Shapes(ShapeName)
On Error GoTo 0
ShapeExists = Not Shp Is Nothing
End Function
For example if you have the following shape names in your sheet
Flower
Flower
Flower
Flower
Flower2
Bus
Car
Car
Car
After using the code the got renamed to
Flower1
Flower3
Flower4
Flower5
Flower2
Bus
Car1
Car2
Car3
Note that the renaming algorithm detects if renaming is necessary. For example Bus didn't need to be renamed as it was unique already. Also it detects that Flower2 already existed and jumps that number 2 when renaming the 4 Flower shapes so you end up with Flower1…5 otherwise you would end up with 2 Flower2 shapes.
The following code snippet can be used for debugging to list all the shape names and check them quickly:
Public Sub ListAllShapeNamesInActiveSheet()
ListAllShapeNames InWorksheet:=ActiveSheet
End Sub
Public Sub ListAllShapeNames(ByVal InWorksheet As Worksheet)
Dim Shp As Shape
For Each Shp In InWorksheet.Shapes
Debug.Print Shp.Name
Next Shp
End Sub