'=========================================================================================
' 290 コマンドバーのボタンイメージをコピーしてワークシートに貼り付けする
'-----------------------------------------------------------------------------------------
'【ヒント】
' このマクロは、おためし機能の動作用のコードを含んでいます。（概ね下半分）
' ★★★の行またはサブプロシージャーが、タイトル機能に関係するコードです。（概ね上半分）


'=========================================================================================
' ◆標準モジュールのコード◆
'-----------------------------------------------------------------------------------------
Option Explicit
Dim コントロール As Object                      '★★★
Dim 番号 As Variant                             '★★★
Dim 行 As Integer                               '★★★
Dim 列 As Integer                               '★★★
Dim 補正 As Integer                             '★★★
Dim タイトル As String
Dim スタイル As Long
Dim メッセージ As String
Dim 応答 As Variant


'=========================================================================================
Private Sub コマンドバーのボタンイメージをコピーしてワークシートに貼り付けする() '★★★
    行 = 1
    列 = 1
    補正 = 0
    For 番号 = 1 To 500
        Set コントロール = CommandBars.FindControl(Type:=msoControlButton, ID:=番号) 'オブジェクトをセットする
        On Error Resume Next
        コントロール.CopyFace                   'ボタンイメージをコピーする
        If Err.Number <> 91 Then                '91=オブジェクト変数が定義されていないエラー
            Range(Cells(行 - 補正, 列 + 1), Cells(行 - 補正, 列 + 1)).Select 'セルを選択する
            ActiveSheet.Pictures.Paste.Select   '図を貼り付ける
            Range(Cells(行 - 補正, 列), Cells(行 - 補正, 列)).Value = 番号 'ID番号
            Range(Cells(行 - 補正, 列), Cells(行 - 補正, 列)).Interior.ColorIndex = 36
        行 = 行 + 1
        End If
        If 番号 = 100 Then 行 = 番号 + 1: 列 = 3: 補正 = 100
        If 番号 = 200 Then 行 = 番号 + 1: 列 = 5: 補正 = 200
        If 番号 = 300 Then 行 = 番号 + 1: 列 = 7: 補正 = 300
        If 番号 = 400 Then 行 = 番号 + 1: 列 = 9: 補正 = 400
    Next
    On Error GoTo 0
End Sub
'=========================================================================================



'-----------------------------------------------------------------------------------------
Sub おためしマクロ()
    おためしメッセージを表示する
    コマンドバーのボタンイメージをコピーしてワークシートに貼り付けする '★★★
    一覧シートを整える
End Sub
'-----------------------------------------------------------------------------------------
Private Sub おためしメッセージを表示する()
    Worksheets("Title").Select
    Range("P17").Select                        'カーソルを定位置へ移動する
    タイトル = "500連発 第2弾 サンプルマクロ"
    スタイル = 64                               'vbInformation
    メッセージ = "ボタンイメージ (ID 1から 500まで) をコピーして、" & Chr(13) & Chr(13) & _
                "「一覧」シートに貼り付けます。" & Chr(13) & Chr(13) & _
                " (未定義の番号は飛ばします)"
    応答 = MsgBox(メッセージ, スタイル, タイトル)
    Application.DisplayAlerts = False           '確認メッセージを出さない
    Sheets("一覧").Delete
    Sheets.Add
    ActiveSheet.Name = "一覧"
End Sub
'-----------------------------------------------------------------------------------------
Sub 一覧シートを整える()
    Rows("1:1").Insert Shift:=xlDown
    Range("A1").Value = "ID"
    Range("B1").Value = "ボタン"
    Range("A1").Interior.ColorIndex = 36
    Range("B1").Interior.ColorIndex = 35
    Range("A1:B1").HorizontalAlignment = xlCenter
    Range("A1:B1").Copy
    Range("C1:J1").PasteSpecial Paste:=xlAll
    Application.CutCopyMode = False
    Range("A1").Select
End Sub
'-----------------------------------------------------------------------------------------
Sub Auto_Close()
    Application.DisplayAlerts = False           '閉じる際に確認メッセージを出さない
    ActiveWorkbook.Close                        '現在開いているブックを閉じる
End Sub
'-----------------------------------------------------------------------------------------