VBA - Fonts

Display a list of all Fonts currently installed

Sub FontSamples()
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

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