トップ　>　汎用コード　>　指定したシート内のオブジェクト一覧を作成する

'--------------------------------------------------------------------------------
' 実行マクロ　［ 新規ブックにアクティブシートのオブジェクト情報を出力 ］
'--------------------------------------------------------------------------------
Sub ExampleOfUse_GetObjectInfo()

    Dim varObjName    As Variant
    Dim varObjType    As Variant
    Dim varObjTypeNum As Variant
    Dim lngCount      As Long

    'プロシージャ実行
    lngCount = GetObjectInfo(ActiveSheet, varObjName, varObjType, varObjTypeNum)
    
    If lngCount = 0 Then
        MsgBox "オブジェクトはありません"
    Else
        '新規ブックを追加
        Workbooks.Add
        
        '見出し設定
        With Range("A1:C1")
            .Value = Array("オブジェクト名", "タイプ", "タイプ番号")
            .Interior.ThemeColor = xlThemeColorAccent5
            .Interior.TintAndShade = 0.799981688894314
        End With
        
        'セルに展開
        Dim i As Long
        For i = 0 To lngCount - 1
            Range("A2:C2").Offset(i) = Array(varObjName(i), varObjType(i), varObjTypeNum(i))
        Next
        
        '罫線設定
        ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
        
        '列幅調整
        Columns("A:C").AutoFit
        
        MsgBox lngCount & "つのオブジェクト情報を取得しました", vbInformation
    End If
    
End Sub

'-----------------------------------------------------------------------------------
' 指定したシートのオブジェクト情報を取得
'-----------------------------------------------------------------------------------
'  ※「入力規則」の「ドロップダウンリスト」は取得対象外としています
'［引数］
'   Sh               ：対象のシート
'   Array1dName      ：任意のVariant型変数を指定
'                      オブジェクトが存在した場合オブジェクト名が格納される
'   Array1dType      ：任意のVariant型変数を指定
'                      オブジェクトが存在した場合オブジェクトタイプが格納される
'   Array1dTypeNumber：任意のVariant型変数を指定
'                      オブジェクトが存在した場合オブジェクトタイプ番号が格納される
'［戻り値］
'   オブジェクトの数
'［作成日］
'   2023/06/23
'-----------------------------------------------------------------------------------
Function GetObjectInfo(ByRef Sh As Worksheet, _
                       ByRef Array1dName As Variant, _
                       ByRef Array1dType As Variant, _
                       ByRef Array1dTypeNumber As Variant) As Variant
    'オブジェクトがなければ抜ける
    If Sh.DrawingObjects.Count = 0 Then Exit Function

    'msoShapeType列挙を配列に格納
    Dim varObjectTypeList As Variant
    varObjectTypeList = Array("msoShapeTypeMixed", "", "", "msoAutoShape", _
                              "msoCallout", "msoChart", "msoComment", _
                              "msoFreeform", "msoGroup", "msoEmbeddedOLEObject", _
                              "msoFormControl", "msoLine", "msoLinkedOLEObject", _
                              "msoLinkedPicture", "msoOLEControlObject", _
                              "msoPicture", "msoPlaceholder", "msoTextEffect", _
                              "msoMedia", "msoTextBox", "msoScriptAnchor", _
                              "msoTable", "msoCanvas", "msoDiagram", "msoInk", _
                              "msoInkComment", "msoSmartArt", "msoSlicer", _
                              "msoWebVideo", "msoContentApp", "msoGraphic", _
                              "msoLinkedGraphic", "mso3DModel", "msoLinked3DModel")

    'オブジェクトの名前・タイプ・タイプ番号を取得
    Dim objShape As Shape
    Dim lngCount As Long
    Dim varObjectName()       As Variant
    Dim varObjectType()       As Variant
    Dim varObjectTypeNumber() As Variant
    
    For Each objShape In Sh.Shapes
        With objShape
            '入力規則の「リスト」は対象外
            If Not (.Type = msoFormControl And Left$(.Name, 9) = "Drop Down") Then
                ReDim Preserve varObjectName(lngCount)
                ReDim Preserve varObjectTypeNumber(lngCount)
                ReDim Preserve varObjectType(lngCount)
                
                'オブジェクト名・タイプ・タイプ番号を配列に格納
                varObjectName(lngCount) = .Name
                varObjectTypeNumber(lngCount) = .Type
                varObjectType(lngCount) = varObjectTypeList(.Type + 2)
                lngCount = lngCount + 1
            End If
        End With
    Next

    Array1dName = varObjectName
    Array1dType = varObjectType
    Array1dTypeNumber = varObjectTypeNumber
    GetObjectInfo = lngCount
End Function