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)
    .TypeParagraph
    .Style = wdStyleBodyText
    .Font.Name = AllFonts(i)
    .TypeText Text:=SampleText
    .TypeParagraph
    .TypeParagraph
  End With
Next i
StyDoc.TablesOfContents( 1 ).Update
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
End Sub