单击子形状时获取父形状的名称

Question

我有 2 个名为“Group1”和“Group2”的分组形状，每个包含 2 个名为“Rectangle1”和“Rectangle2”的形状。

当我在任意两个分组形状中单击“Rectangle1”时，它总是返回“Group1”（按顺序排在第一位）。

是否有返回特定子形状的分组形状名称而不更改其名称？

谢谢。

Public Sub ReturnParentName()
   Dim shp as Shape

   Set shp = ActiveSheet.Shapes(Application.Caller).ParentGroup
   MsgBox shp.Name
End Sub

Answer 1

请用这种方式试试：

Sub CommonProcedure_Click()
   Debug.Print Application.Caller 'the shape name
   Debug.Print ActiveSheet.Shapes(Application.Caller).Parent.Name      'the sheet keeping the shape/group name
   If ActiveSheet.Shapes(Application.Caller).Child Then
        Debug.Print ActiveSheet.Shapes(Application.Caller).ParentGroup.Name
    Else
        Debug.Print "Not in a group..."
    End If
End Sub

为了自动更改同名形状的名称，您可以使用下一个代码。它需要添加对“Microsoft Scripting Runtime”的引用。可以使用后期绑定来完成，但我认为应该受益于智能感知建议：

Sub changeShapesSameName()
   Dim sh As Shape, shG As Shape, dict As New Scripting.dictionary
   For Each sh In ActiveSheet.Shapes
       If sh.Type = 6 Then
            For Each shG In sh.GroupItems
                    If Not dict.Exists(shG.Name) Then
                        dict.Add shG.Name, shG.Id
                    Else
                        If dict(shG.Name) <> shG.Id Then shG.Name = shG.Name & shG.Id
                        dict.Add shG.Name, shG.Id 'only to see the sheets balance at the end
                    End If
            Next
       Else
            If Not dict.Exists(sh.Name) Then
                    dict.Add sh.Name, sh.Id
            Else
                    If dict(sh.Name) <> sh.Id Then sh.Name = sh.Name & sh.Id
                    dict.Add sh.Name, sh.Id       'only to see the sheets balance at the end
            End If
       End If
   Next
   Debug.Print dict.count            'total number of individual shapes
   Debug.Print Join(dict.Keys, "|")  'dictionary keys (all shapes name)
   Debug.Print Join(dict.items, ":") 'dictionary items (all shapes IDs)
End Sub

如果还没有添加必要的引用，接下来的代码会自动添加：

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  On Error Resume Next
  Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
  If err.Number = 32813 Then
        err.Clear: On Error GoTo 0
        MsgBox "The reference already exists...": Exit Sub
  Else
        On Error GoTo 0
        MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
  End If
End Sub