Option Explicit

Sub CBShowButtonFaceIDs()
    'CommandBarShowButtonFaceIDs
    '   Excel(Word)に登録されているFaceIdをすべてExcel表(Word文書)に書き込みます。
    '   FaceIdは3000以上ありますので、5分以上かかると思います。
    '   嫌になったらCtrl+Brakeで中止してください。
    '   (余談)
    '   書き込まれたアイコンをコピーして画像系のソフトにペーストしようとしても
    '   クリップボードに実態がないためペーストできません。不思議なことにWindows付属の
    '   ペイントにはペーストできます。私たちが覗いちゃいけない秘密のクリップボードが
    '   あるみたいです。もちろんペイントからコピーすれば画像系のソフトにペーストできます。
    
    Const lngIDStart = 1    'FaceIdスタート
    Const lngIDStop = 10000 'FaceIdエンド
    
    Dim cbrNewToolbar   As CommandBar
    Dim cmdNewButton    As CommandBarButton
    Dim intCntr         As Integer
    Dim c As Integer
    
    ' ツール バーが存在する場合は削除します。
    On Error Resume Next
    Application.CommandBars("ShowFaceIds").Delete
    
    ' 新しいツール バーを作成します。
    Set cbrNewToolbar = Application.CommandBars.Add(Name:="ShowFaceIds", temporary:=True)
    ' 新しいボタンを作成します。
    Set cmdNewButton = cbrNewToolbar.Controls.Add(Type:=msoControlButton)
    c = 1
    ' intCntr で示されている FaceId プロパティ値と一致するイメージをボタンに表示します
    On Error Resume Next
    For intCntr = lngIDStart To lngIDStop
        With cmdNewButton
            ' FaceId プロパティに値を設定します
            .FaceId = intCntr
            If Err = 0 Then
                c = c + 1
                .TooltipText = "FaceId = " & intCntr
                '------- Word Start -------
                'Selection.TypeText Text:=Str(intCntr) & Space$(10)
                '------- Word End ---------
                '------- Excel Start ------
                Range("a" & c).Value = intCntr
                '------- Excel End --------
                .CopyFace
                '------- Word Start -------
                'Selection.Paste
                'Selection.TypeParagraph
                '------- Word End ---------
                '------- Excel Start ------
                Range("b" & c).Select
                ActiveSheet.Paste
                '------- Excel End --------
            Else
                Err.Clear
            End If
        End With
    Next intCntr
    
    Set cmdNewButton = Nothing
    Set cbrNewToolbar = Nothing
End Sub