在 Excel 中复制和粘贴图像会锁定参考

Question

我正在尝试使用 VBA 管理图片，但遇到了一些问题

我有一个 Excel 电子表格，其中的图片具有自定义名称“花”

当我复制和粘贴时，新图像保持相同的名称“花”

我添加了一个宏，当我点击图片时，它会告诉我点击的是哪张图片。

Sub ImageClicked()
' ImageClicked

    shapeID = ActiveSheet.Shapes(Application.Caller).ID 
    MsgBox (shapeID)
End Sub

但问题是当我点击两张图片时，输出是一样的，它显示相同的ID。

当我删除第一个原始图像并单击第二个图像时，显示的 ID 会发生变化。

我做错了什么吗？

附：我已经想通了，如果我原来的形状是“矩形 1”，那么复制出来的形状就是“矩形 2”，没有问题。

Answer 1

您实际遇到的问题是您的形状名称不是唯一的，VBA 现在会选择它找到的第一个具有该名称的形状。这是由于 Excel 中的一个错误，即如果您复制形状，它们的名称完全相同，但不能有重复的名称。

我多次遇到这个错误，所以我编写了一个代码来轻松修复它并确保形状名称是唯一的。有时您无法控制复制/粘贴过程，因为其他用户这样做了并且仍然需要唯一的名称。

您可以使用以下代码来确保活动工作表中的形状名称唯一。

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

例如，如果您的工作表中有以下形状名称

Flower
Flower
Flower
Flower
Flower2
Bus
Car
Car
Car

使用代码后重命名为

Flower1
Flower3
Flower4
Flower5
Flower2
Bus
Car1
Car2
Car3

请注意，重命名算法会检测是否需要重命名。例如Bus 不需要重命名，因为它已经是唯一的。它还检测到 Flower2 已经存在并在重命名 4 个 Flower 形状时跳过该数字 2，因此您最终会得到 Flower1…5，否则您最终会得到 2 个 Flower2 形状。

---

以下代码sn-p可用于调试，列出所有形状名称并快速查看：

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