点击组合形状内的子形状时如何获取其所属父组合的正确名称

问题原因 #

Application.Caller在形状触发宏时仅返回被点击形状的名称，当工作表内存在多个重名形状时，ActiveSheet.Shapes(名称)只会返回形状集合中第一个匹配该名称的对象，所以你点击任意Group下的Rectangle1都会匹配到Group1下的同名形状，最终返回的父组名永远是Group1。

最优解（无需提前预处理，适配动态新增组合场景） #

通过点击位置直接定位实际被点击的形状，完全避开重名匹配的问题，不需要修改任何形状的名称：

Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Sub ReturnParentName()
    Dim pt As POINTAPI
    Dim clickedShape As Object
    
    ' 获取点击时的鼠标坐标
    GetCursorPos pt
    ' 从坐标位置获取实际被点击的对象
    Set clickedShape = ActiveWindow.RangeFromPoint(pt.X, pt.Y)
    
    ' 判断对象是否为形状且属于组合
    If TypeName(clickedShape) = "Shape" Then
        If Not clickedShape.ParentGroup Is Nothing Then
            MsgBox clickedShape.ParentGroup.Name
        Else
            MsgBox "当前点击的形状不属于任何组合"
        End If
    End If
End Sub

注意事项 #

• 代码适配32位和64位Office，无需额外调整
• 完全不需要修改现有形状的命名规则，新增组合后也不需要做额外配置

备选方案（适合固定组合场景，触发速度更快） #

如果你的工作表内组合不会频繁变动，可以提前给所有子形状备注父组名称，后续点击直接读取即可：

1. 先运行一次批量赋值脚本，将父组名写入子形状的AlternativeText属性：

Sub BatchSetParentNameToAltText()
    Dim groupShp As Shape, subShp As Shape
    For Each groupShp In ActiveSheet.Shapes
        If groupShp.Type = msoGroup Then
            For Each subShp In groupShp.GroupItems
                subShp.AlternativeText = groupShp.Name
            Next
        End If
    Next
End Sub

2. 后续触发的宏直接读取备注内容即可：

Public Sub ReturnParentName()
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes(Application.Caller)
    MsgBox shp.AlternativeText
End Sub

注意事项 #

• 每次新增、修改组合结构后，需要重新运行一次批量赋值脚本更新备注内容
• 触发查询的速度比坐标定位方案更快

内容的提问来源于stack exchange，提问作者Tornado168