利用できる imageMso を一覧するマクロ

背景

先日、幸運にも Kingsoft の Office スイートを試用する機会がありました。VBA も使えるエディションです。

[asin:B01N5A2PG5:detail]

主に MS Excel 代替の WPS Spreadsheets を確認しました。エンジニアの視点から、VBA の実行やカスタマイズしたリボンの挙動などを厳しく確認しましたが、再現性の高さに驚かされました ¹ 。VBE さえ付いています。

その他、自前で開発したアドインのリボンに使っている imageMso が一部表示されていないことにも気づきました ² 。

もし Kingsoft 製の Office に移行する場合、どういった imageMso が使えて（ちゃんと表示されて）、どういったものが使えないのか、開発者としてはこれを把握する必要があります。

下記のサイトを参考にして、imageMso を一覧するマクロを作成しました。

VBA アドイン作成で使用するリボンアイコンの組み込み画像(ImageMSO)をBitmapで一括保存する方法 - t-hom’s diary

準備

まず、以下の MS サイトから imageMso の一覧「imageMso.txt」をダウンロードします。

Download Microsoft Office Document: [MS-CUSTOMUI2] Supporting Documentation from Official Microsoft Download Center

imageMso.txt の内容はタブ区切りテキストになっているので、そのまま「全選択」->「コピー」->ワークシートに「貼り付け」できます。

マクロを実行

コピペしたら、そのワークシートがアクティブになっている状態で以下のコードを実行します。

Option Explicit

Sub listupImageMso()
    Dim i As Long
    Dim lastRow As Long
    Dim tmpPath As String
    Dim tmpShape As Shape
    Dim cb As CommandBars
    
    lastRow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    Rows("2:" & lastRow).RowHeight = 32
    tmpPath = Environ("temp") & "\tmpImage.png"
    Set cb = Application.CommandBars
    
    On Error Resume Next
    Application.ScreenUpdating = False
    
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        ActiveSheet.Shapes(i).Delete
    Next
    
    For i = 2 To lastRow
        Cells(i, 4).Select
        stdole.SavePicture cb.GetImageMso(Cells(i, 1).Value, 32, 32), tmpPath
        
        Set tmpShape = ActiveSheet.Shapes.AddPicture( _
              Filename:=tmpPath, _
              LinkToFile:=False, _
              SaveWithDocument:=True, _
              Left:=Selection.Left, _
              Top:=Selection.Top, _
              Width:=0, _
              Height:=0)
              
        With tmpShape
            .ScaleHeight 1, msoTrue
            .ScaleWidth 1, msoTrue
        End With
        
        If i Mod 200 = 0 Then
            Debug.Print i
            DoEvents
        End If
    Next
    
    Application.ScreenUpdating = True
    On Error GoTo 0
    
    Range("A1").Select
    
End Sub