自分でインストールしたフォント名一覧を作成するExcelマクロ

Sub 自分でインストールしたフォントの一覧を作成する()
　' ワークシートの挿入
　Dim sht As Worksheet
　Set sht = Sheets.Add(Before:=Sheets(1))
　sht.Cells(1, 1).Value = "全角文字を含むフォント一覧（特定プレフィックス除外）"
　
　' システムのフォント一覧を取得
　Dim font_list As Object
　Set font_list = Application.CommandBars("Formatting").FindControl(ID:=1728)
　If font_list Is Nothing Then
　　MsgBox "フォントリストを取得できませんでした。"
　　Exit Sub
　End If
　
　' 全角文字を含むフォントを抽出（特定プレフィックスを除外）
　Dim row_num As Long
　row_num = 2
　
　Dim i As Long
　For i = 1 To font_list.ListCount
　　Dim font_name As String
　　font_name = font_list.List(i)
　　If _
　　　HasFullWidthChar(font_name) And _
　　　Not HasExcludedPrefix(font_name) Then
　　　　With sht.Cells(row_num, 1)
　　　　　.Value = font_name
　　　　　.Font.Name = font_name
　　　　End With
　　　row_num = row_num + 1
　　End If
　Next i
　
　' リストのフォントサイズと列幅を調整
　sht.Columns(1).Font.Size = 20
　sht.Columns(1).AutoFit
　
End Sub

' 全角文字が含まれているか判定する関数
Function HasFullWidthChar(txt As String) As Boolean
　Dim i As Long
　For i = 1 To Len(txt)
　　Dim char_code As Long
　　char_code = AscW(Mid(txt, i, 1))
　　If char_code > 255 Then
　　　HasFullWidthChar = True
　　　Exit Function
　　End If
　Next i
　HasFullWidthChar = False
End Function

' 除外するプレフィックスを持つか判定する関数
Function HasExcludedPrefix(font_name As String) As Boolean
　Dim arr_prefix As Variant
　arr_prefix = Array("游", "メイリオ", "BIZ", "HG", "ＭＳ", "UD")
　
　Dim i As Variant
　For Each i In arr_prefix
　　If Left(font_name, Len(i)) = i Then
　　　HasExcludedPrefix = True
　　　Exit Function
　　End If
　Next i
　HasExcludedPrefix = False
End Function