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

' 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

End With

Next i

StyDoc.TablesOfContents( 1 ).Update

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

End Sub