インストールしたと思われるフォント名一覧を作成する「没」にしたExcelマクロ

Grokに指示を出して作った、自分でインストールしたフォント名一覧を作成するExcelマクロをご紹介しています。

電車の中で思いついて、スマホでGrokに指示を出して作り始めました。

最初は、Windowsにデフォルトでインストールされるフォントを除外したフォント名の一覧を作成するマクロを考えていたのですが、ある程度できたので電車を降り、パソコンで実行してみたところ、想像以上にたくさんのフォント名が一覧として出力されたため、途中で仕様を変更したものです。

（せっかくなので？）最初の仕様のマクロも公開しておきます。

' モジュールスコープでデフォルトフォントのプレフィックスコレクションを定義
Private m_default_font_list As Collection

' モジュールの初期化時にコレクションを設定
Private Sub InitializeDefaultFontPrefixes()
    Set m_default_font_list = New Collection
    
    ' Windows 11のデフォルトフォントの「最初のスペースまで」を追加
    ' Microsoft Learn (https://learn.microsoft.com/en-us/typography/fonts/windows_11_font_list) に基づく
    m_default_font_list.Add "Arial"
    m_default_font_list.Add "Bahnschrift"
    m_default_font_list.Add "Calibri"
    m_default_font_list.Add "Cambria"
    m_default_font_list.Add "Candara"
    m_default_font_list.Add "Consolas"
    m_default_font_list.Add "Constantia"
    m_default_font_list.Add "Corbel"
    m_default_font_list.Add "Courier"      ' Courier New
    m_default_font_list.Add "Ebrima"
    m_default_font_list.Add "Franklin"     ' Franklin Gothic
    m_default_font_list.Add "Gabriola"
    m_default_font_list.Add "Gadugi"
    m_default_font_list.Add "Georgia"
    m_default_font_list.Add "HoloLens"     ' HoloLens MDL2 Assets
    m_default_font_list.Add "Impact"
    m_default_font_list.Add "Ink"          ' Ink Free
    m_default_font_list.Add "Javanese"     ' Javanese Text
    m_default_font_list.Add "Leelawadee"   ' Leelawadee UI
    m_default_font_list.Add "Lucida"       ' Lucida Console, Lucida Sans Unicode
    m_default_font_list.Add "Malgun"       ' Malgun Gothic
    m_default_font_list.Add "Marlett"
    m_default_font_list.Add "Microsoft"    ' Microsoft Himalaya, Microsoft JhengHei, etc.
    m_default_font_list.Add "MingLiU-ExtB"
    m_default_font_list.Add "MingLiU_HKSCS-ExtB"
    m_default_font_list.Add "Mongolian"    ' Mongolian Baiti
    m_default_font_list.Add "ＭＳ"         ' MS Gothic, MS PGothic, MS UI Gothic, MS Mincho, MS PMincho (日本語名)
    m_default_font_list.Add "MV"           ' MV Boli
    m_default_font_list.Add "Myanmar"      ' Myanmar Text
    m_default_font_list.Add "Nirmala"      ' Nirmala UI
    m_default_font_list.Add "Palatino"     ' Palatino Linotype
    m_default_font_list.Add "Segoe"        ' Segoe Fluent Icons, Segoe MDL2 Assets, etc.
    m_default_font_list.Add "SimSun"
    m_default_font_list.Add "SimSun-ExtB"
    m_default_font_list.Add "Sitka"        ' Sitka Small, Sitka Text
    m_default_font_list.Add "Sylfaen"
    m_default_font_list.Add "Symbol"
    m_default_font_list.Add "Tahoma"
    m_default_font_list.Add "Times"        ' Times New Roman
    m_default_font_list.Add "Trebuchet"    ' Trebuchet MS
    m_default_font_list.Add "Verdana"
    m_default_font_list.Add "Webdings"
    m_default_font_list.Add "Wingdings"
    m_default_font_list.Add "Yu"           ' Yu Gothic, Yu Gothic UI, Yu Mincho
    m_default_font_list.Add "メイリオ"     ' Meiryo, Meiryo UI (日本語名)
    m_default_font_list.Add "游ゴシック"   ' Yu Gothic (日本語名)
    m_default_font_list.Add "游明朝"       ' Yu Mincho (日本語名)
End Sub

' メイン処理
Sub Windowsがインストールするのではないフォントの一覧を作成する()
    Dim font_list As Object
    Dim index As Long
    Dim Worksheet As Worksheet
    Dim font_name As String
    Dim row_num As Long
    
    ' m_default_font_listが未初期化なら初期化
    If m_default_font_list Is Nothing Then
        InitializeDefaultFontPrefixes
    End If
    
    ' ワークシートを設定
    Set Worksheet = ThisWorkbook.Sheets(1)
    Worksheet.Cells.Clear
    Worksheet.Cells(1, 1).Value = "非デフォルトフォント一覧"
    
    ' システムのフォント一覧を取得
    Set font_list = Application.CommandBars("Formatting").FindControl(ID:=1728)
    If font_list Is Nothing Then
        MsgBox "フォントリストを取得できませんでした。"
        Exit Sub
    End If
    
    ' 非デフォルトフォントを抽出して出力
    row_num = 2
    For index = 1 To font_list.ListCount
        font_name = font_list.List(index)
        If Not IsInCollection(font_name) Then
            With Worksheet.Cells(row_num, 1)
                .Value = font_name
                ' フォント名をそのフォントで表示
                On Error Resume Next  ' フォントが適用できない場合に備える
                .Font.Name = font_name
                On Error GoTo 0
            End With
            row_num = row_num + 1
        End If
    Next index
    
    ' 列幅を調整
    Worksheet.Columns(1).AutoFit
End Sub

' ヘルパー関数（モジュール変数を直接参照）
Function IsInCollection(item As String) As Boolean
    Dim v As Variant
    Dim prefix_len As Long
    Dim item_prefix As String
    
    On Error Resume Next
    For Each v In m_default_font_list
        prefix_len = Len(v)
        If Len(item) >= prefix_len Then
            item_prefix = Left(item, prefix_len)
            If v = item_prefix Then
                IsInCollection = True
                Exit Function
            End If
        End If
    Next v
    IsInCollection = False
    On Error GoTo 0
End Function

最終更新日時：2025-04-04 05:56