Print samples of every font on your system

Article contributed by John McGhie

It used to be simple to do this -- the macro was so simple you could just type it every time you needed it.  However, due to a bug in the fonts mechanism of Word 2003 the macro becomes unnecessarily complex to write.  It appears that the built-in FontNames collection is not correctly defined: the data type of the collection index and its content seem to be mismatched.  The following macro works (laboriously) around this.  Note:  This macro is not compatible with Mac Word.  It will run, but Word may produce errors.

Sub FontSamples()

  ' Samples all fonts installed

  ' Macro written 31 March 2006 by John McGhie


  Const SampleText As String = "the quick brown fox jumps over the lazy dog." & _

      " THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 0 1 2 3 4 5 6 7 8 9"


  Dim i As Long

  ' Make our own array because FontNames is FUBARed

  Dim AllFonts() As String

  Dim StyDoc As Document


  Set StyDoc = Application.Documents.Add


  ' Resize the array the way we want it (in case the user has an Option Base set)

  ReDim AllFonts( 1 To FontNames.Count)

  ' Load the array one by one from FontNames

  For i = 1 To FontNames.Count

    AllFonts(i) = FontNames(i)

  Next i

  ' Use the WordBasic sort because VBA doesn't have one!!

  WordBasic.SortArray AllFonts$()


  ' Adjust the styles we want to use in the document we just created

  With StyDoc.Styles

    With .Item(wdStyleHeading1)

      .Font.Color = wdColorBlue

      .ParagraphFormat.PageBreakBefore = False

    End With

    With .Item(wdStyleBodyText)

      .Font.Size = 36

      .Font.Color = wdColorAutomatic

    End With

  End With


  ' Add a TOC so we can list the styles and find them later

  With StyDoc.TablesOfContents

    .Add Range:=Selection.Range, RightAlignPageNumbers:= _

        True , UseHeadingStyles:= True , UpperHeadingLevel:= 1 , _

        LowerHeadingLevel:= 1 , IncludePageNumbers:= True , AddedStyles:= ""

    .Item( 1 ).TabLeader = wdTabLeaderDots

    .Format = wdIndexIndent

  End With


  ' there's a bug in FontNames collection, in WD2003 we can't

  ' use For Each ... Next, it errors due to a type mismatch


  For i = 1 To UBound (AllFonts)

    With Selection

      .Style = wdStyleHeading1

      .TypeText Text:=AllFonts(i)


      .Style = wdStyleBodyText

      .Font.Name = AllFonts(i)

      .TypeText Text:=SampleText



    End With

  Next i


  StyDoc.TablesOfContents( 1 ).Update

  Selection.HomeKey Unit:=wdStory, Extend:=wdMove


End Sub