Display all installed fonts (Word)

The macros below will display a list of all installed fonts.
Note! If you have many fonts installed, the macro may stop responding because of lack of available memory.

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

Document last updated 2000-04-15 12:49:20