リボンのアイコンをファイルとして保存する(6)

つづき

misora05.hatenablog.com

今回は，前回の内容を踏まえ，入手したファイルをから実際にアイコンを抽出するコードを書いてみましょう．
コードを実際に載せる都合上，少々長めになりますがご容赦を．

手に入れたファイルを処理してみよう．

"imageMSO.txt"とその仲間たち

これのダウンロードサイトからは，以下の3ファイルも入手できます．

ExcelControls.txt
PowerPointControls.txt
WordControls.txt

これらも併せて一緒に処理してしまいましょう．

これらについての形式は割愛しますが，「1列目の値がimageMSO属性値に対応する」という点についてはimageMso.txtと同一であり，したがってそれと同一に処理してしまって構わないでしょう――些か乱暴ですが．

Public Function Save_ImageMSO_A() As Long
    
    Save_ImageMSO_A = 0
    
    Dim fso As New Scripting.FileSystemObject
    
    Dim cbs As Office.CommandBars: Set cbs = Application.CommandBars
    
    Dim ws As Excel.Worksheet, lso As Excel.ListObject, lsrow As Excel.ListRow
    
    For Each ws In ThisWorkbook.Worksheets
        For Each lso In ws.ListObjects
            For Each lsrow In lso.ListRows
                Dim idMSO As String: idMSO = lsrow.Range.Cells(1, 1).Value
                
                If Len(idMSO) > 0 And Not fso.FileExists(fso.BuildPath(ThisWorkbook.Path, idMSO & ".BMP")) Then
                    On Error Resume Next
                    
                    Debug.Print lsrow.Index, idMSO
                    
                    Dim img As stdole.IPictureDisp
                    Set img = cbs.GetImageMso(idMSO, 32, 32)
                    
                    If Err.Number = 0 Then
                        Call stdole.SavePicture(img, fso.BuildPath(ThisWorkbook.Path, idMSO & ".BMP"))
                        
                        If Err.Number = 0 Then
                            Save_ImageMSO_A = Save_ImageMSO_A + 1
                        End If
                    End If
                    
                    If Err.Number <> 0 Then
                        Debug.Print Err.Number, Err.Description
                        Call Err.Clear
                    End If
                    
                    On Error GoTo 0
                End If
            Next
        Next
    Next
    
End Function

各テキストファイルはそれぞれ異なるワークシートに，テーブル(ListObjectオブジェクト)としてインポートされたので，一応それに合わせて処理するようにしています．

コメント等は割愛していますが，単純なコードですのでまぁ問題はないでしょう．一応,

事前にファイルの存在を確認し，既に出力されたアイコンであると判断した場合は出力処理を省略する．
エラーが起きても(≒そのアイコンが私の使用しているバージョンのOfficeに存在しない)無視して続行する．

このようにはなっています．
結果は下記の通り．

よっしゃよっしゃ．

"office-fluent-ui-command-identifiers"リポジトリより入手したファイルたち

これらのファイルは，

フォルダごとに，
XLSX形式で，
テーブルを使って

格納されているので，最初に対象のフォルダを選び，そこにある全XLSX形式ファイルを処理対象とするようにしてみましょうか．

Public Function Save_ImageMSO_B() As Long
    
    Save_ImageMSO_B = 0
    
    Dim fso As New Scripting.FileSystemObject
    
    Dim cbs As Office.CommandBars: Set cbs = Application.CommandBars
    
    Dim wb As Excel.Workbook
    Dim f As Scripting.File, ws As Excel.Worksheet, lso As Excel.ListObject, lsrow As Excel.ListRow
    
    Dim TargetFolder As String
    Dim dlg As Office.FileDialog: Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    With dlg
        If .Show() Then
            TargetFolder = .SelectedItems(1)
        Else
            Exit Function
        End If
    End With
    
    For Each f In fso.GetFolder(TargetFolder).Files
        If UCase(f.Name) Like "*.XLSX" Then
            Set wb = Application.Workbooks.Open(f.Path)
            
            For Each ws In ThisWorkbook.Worksheets
                For Each lso In ws.ListObjects
                    For Each lsrow In lso.ListRows
                        Dim idMSO As String: idMSO = lsrow.Range.Cells(1, 1).Value
                        
                        If Len(idMSO) > 0 And Not fso.FileExists(fso.BuildPath(TargetFolder, idMSO & ".BMP")) Then
                            On Error Resume Next
                            
                            Debug.Print lsrow.Index, idMSO
                            
                            Dim img As stdole.IPictureDisp
                            Set img = cbs.GetImageMso(idMSO, 32, 32)
                            
                            If Err.Number = 0 Then
                                Call stdole.SavePicture(img, fso.BuildPath(TargetFolder, idMSO & ".BMP"))
                                
                                If Err.Number = 0 Then
                                    Save_ImageMSO_B = Save_ImageMSO_B + 1
                                End If
                            End If
                            
                            If Err.Number <> 0 Then
                                Debug.Print Err.Number, Err.Description
                                Call Err.Clear
                            End If
                            
                            On Error GoTo 0
                        End If
                    Next
                Next
            Next
            
            Call wb.Close
            Set wb = Nothing
        End If
    Next
    
End Function

これをとりあえず「Office 365 半期チャネル(対象指定)」に対して実行してみた結果．