VBA - Fonts

Display a list of all Fonts currently installed

Public Sub CreateTable 
Dim objDocument As Document 
Dim sSampleText As String 
Dim sFontName As String 
Dim objRange As Range 
Dim objStartRange As Range 
Dim lcount As Long 

   Set objDocument = Documents.Add 
   sSampleText = Chr(147) & _ 
       "ABCDEFGHIJKLMNOPQRSTUVWYZ" & Chr(148) & ", " & Chr(147) & _ 
       "abcdefghijklmnopqrstuvwxyz" & Chr(148) & ", " & Chr(147) & _ 
       "The quick brown fox jumps over the lazy dog" & Chr(148) & ", " & Chr(147) & _ 
       "(;,.:£$?!)" & Chr(146) 

   System.Cursor = wdCursorType.wdCursorWait 
   With objDocument 
      For lcount = 1 To Application.FontNames.Count 
         sFontName = Application.FontNames(lcount) 
         StatusBar = "Adding " & sFontName 
         Set objRange = .Range 
         With objRange 
            .Collapse wdCollapseDirection.wdCollapseEnd 
            .Font.Reset 
            .InsertAfter sFontName & " - " & SampleText 
         End With 
         Set objRange = .Range 
         With objRange 
            .Collapse wdCollapseDirection.wdCollapseEnd 
            .InsertAfter sSampleText 
            Set objStartRange = .Duplicate 
            objStartRange.End = .End 
            objStartRange.Font.Name = sFontName 
            .InsertAfter vbCrLf 
         End With 
      Next lcount 

      .Range.Sort FieldNumber:="Paragraphs"   
      .Paragraphs(1).Range.Text = "Font" & vbTab & "Sample" & vbCr 
      .Range.ConvertToTable Format:=wdTableFormat.wdTableFormatClassic1, _ 
                            AutoFit:=True 

      With .Tables(1) 
         .Rows.AllowBreakAcrossPages = False 
         .Rows(1).HeadingFormat = True 
      End With 

   End With 

   System.Cursor =  wdCursorType.wdCursorNormal 
End Sub

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