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