Microsoft ExcelでVBAを使用してインストールされているすべてのフォント（ワード）を表示
以下のマクロは、インストールされているすべてのフォントのリストを表示します。注意！多くのフォントがインストールされている場合、使用可能なメモリが不足しているためにマクロが応答しなくなることがあります。
Sub ShowInstalledFonts()
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
Dim stdFont As String
fontSize = 0
fontSize = InputBox("Enter Sample Font Size Between 8 And 30", _
"Select Sample Font Size", 12)
If fontSize = 0 Then Exit Sub
If fontSize < 8 Then fontSize = 8
If fontSize > 30 Then fontSize = 30
Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
If FontNamesCtrl Is Nothing Then
Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
msoBarFloating, False, True)
Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
End If
Application.ScreenUpdating = False
fontCount = FontNamesCtrl.ListCount
Documents.Add
stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name
' add heading
With ActiveDocument.Paragraphs(1).Range
.Text = "Installed fonts:"
End With
LS 2
' list font names and font example on every other line
For i = 0 To FontNamesCtrl.ListCount - 1
fontName = FontNamesCtrl.List(i + 1)
If i Mod 5 = 0 Then Application.StatusBar = "Listing font " & _
Format(i / (fontCount - 1), "0 %") & " " & _
fontName & "..."
With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
.Text = fontName
.Font.Name = stdFont
End With
LS 1
tFormula = "abcdefghijklmnopqrstuvwxyz"
If Application.International(wdProductLanguageID) = 47 Then
tFormula = tFormula & "æøå"
End If
tFormula = tFormula & UCase(tFormula)
tFormula = tFormula & "1234567890"
With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
.Text = tFormula
.Font.Name = fontName
End With
LS 2
Next i
ActiveDocument.Content.Font.Size = fontSize
Application.StatusBar = False
If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
Set FontCmdBar = Nothing
Set FontNamesCtrl = Nothing
ActiveDocument.Saved = True
Application.ScreenUpdating = True
Application.ScreenRefresh
End Sub
Private Sub LS(lCount As Integer)
' adds lCount new paragraph(s) at the end of the document
Dim i As Integer
With ActiveDocument.Content
For i = 1 To lCount
.InsertParagraphAfter
Next i
End With
End Sub