Beschriftung Shapes Excel 2010

Sub ShowAllShapenames()
    Dim strAllNames As String
    EnumAllShapeObjects ActiveSheet, , strAllNames
    MsgBox strAllNames
End Sub

Sub EnumAllShapeObjects(ByRef sheet As Worksheet, Optional ByVal sh As Shape, Optional ByRef strNames As String)
    On Error Resume Next
    If sh Is Nothing Then
        For Each sh In sheet.Shapes
            EnumAllShapeObjects sheet, sh, strNames
        Next
    Else
        strNames = strNames & sh.Name & vbNewLine
        cnt = sh.GroupItems.Count
        If Err.Number = 0 And cnt > 0 Then
            For Each subshape In sh.GroupItems
                EnumAllShapeObjects sheet, subshape, strNames
            Next
        End If
        Err.Clear
    End If
End Sub