Attribute VB_Name = "Module1"
'■　マクロ５００連発＜第２段＞
'
'　ツールバーのＩＤ一覧表をアイコン付きで作成する
'
'  Copyright(C) 2000 Sunago
'
'　　ツールバーのＩＤ一覧表をアイコン付きで作成します。
'　アイコンイメージはCopyFaceメソッドを使うとクリップボートに
'  コピーすることができます。このマクロではアイコンイメージを
'　クリップボードにコピーした後にPasteメソッドを使ってワーク
'  シートに貼り付けます。
'
'　　CopyFaceメソッドを実行できるコントロールはCommandBarButtonだけです。
'　このマクロではコントロールの種類がmsoControlButtonであれば
'　アイコンイメージを取得しています。
'
Option Explicit

Sub Macro1()
Dim myCBar As Office.CommandBar
Dim myCtrl As Office.CommandBarControl
Dim nval As Integer

    '処理を早くするおまじない(画面の更新を止める)
    Application.ScreenUpdating = False

    'バージョンごとに出力先シートを切り替える
    Select Case Left$(Application.Version, 1)
        Case "8"
            Worksheets("xl97App").Select
        Case "9"
            Worksheets("xl2000App").Select
        Case Else
            Worksheets(2).Select
            Sheets(2).Name = "xl" & Application.Version & "App"
    End Select
    
    Cells.Clear                         '出力シートを初期化する
    
    Range("A1").Select                  '基準セルをA2にセット
    ActiveCell = "Name"
    ActiveCell.Offset(, 1) = "Id"
    ActiveCell.Offset(, 2) = "Caption"
    ActiveCell.Offset(, 3) = "Image"
    ActiveCell.Offset(, 4) = "FaceId"
    'コマンドバーを取得するループ
    For Each myCBar In Application.CommandBars
        'ツールバーのみを処理対象とする
        If myCBar.Type = msoBarTypeNormal Then
            ActiveCell.Offset(1).Select         '基準行を+1する
            ActiveCell = myCBar.Name
            For Each myCtrl In myCBar.Controls
                ActiveCell.Offset(1).Select     '基準行を+1する
                'オートフィルタを利用する場合は次の行のコメントを解除する
                'ActiveCell = myCBar.Name
                'フィルタの\/使用を考慮する
                ActiveCell.Offset(, 1) = myCtrl.Id
                ActiveCell.Offset(, 2) = myCtrl.Caption
                'コントロールの種類がボタンのとき、イメージを貼り付ける
                If myCtrl.Type = msoControlButton Then
                    myCtrl.CopyFace
                    With ActiveSheet
                        .Paste
                        .Shapes(.Shapes.Count).Top = ActiveCell.Offset(, 3).Top
                        .Shapes(.Shapes.Count).Left = ActiveCell.Offset(, 3).Left
                        .Shapes(.Shapes.Count).Width = ActiveCell.Height
                        .Shapes(.Shapes.Count).Height = ActiveCell.Height
                    End With
                    ActiveCell.Offset(, 4) = myCtrl.FaceId
                End If
            Next
        End If
    Next
    
    '列幅を自動調整する
    Columns.AutoFit
    
    Application.ScreenUpdating = True

End Sub