List fonts used in a particular document

John,

This may be a little faster (read tiny bit) as it uses a collection (vice an array) to store the used fonts. 

Option Explicit
Public Sub ListFontsInDoc()
Dim lngJunk As Long
Dim rngStory As Word.Range
Dim oShp As Word.Shape
Dim FontName As String
Dim lngIndex As Long
Dim lngChar As Long
Dim lngCharCount As Long
Dim rngChar As Range
Dim colFontsUsed As New Collection
Dim oDocList As Word.Document

lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each rngStory In ActiveDocument.StoryRanges
  lngChar = 0
  lngCharCount = rngStory.Characters.Count
  Do
    'Evaluate each character.
    For Each rngChar In rngStory.Characters
      lngChar = lngChar + 1
      FontName = rngChar.Font.Name
      StatusBar = "Evaluauting character " & lngChar & " of " & lngCharCount & " characters in the story range."
      'Check if font used for this character is already in the list.
      On Error Resume Next
      'Collection key prevents adding fonts already in the collection.
      colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name
      On Error GoTo 0
    Next rngChar
    'Evaluated shaped in headers and footers.
    Select Case rngStory.StoryType
      Case 6, 7, 8, 9, 10, 11
        'No shape will throw an error that we handle and skip.
        On Error GoTo Err_Handler
        If rngStory.ShapeRange.Count > 0 Then
          For Each oShp In rngStory.ShapeRange
            If oShp.TextFrame.HasText Then
              lngChar = 0
              lngCharCount = oShp.TextFrame.TextRange.Characters.Count
              For Each rngChar In oShp.TextFrame.TextRange.Characters
                lngChar = lngChar + 1
                FontName = rngChar.Font.Name
                StatusBar = "Evaluauting character " & lngChar & " of " & lngCharCount & " characters in the story range."
                On Error Resume Next
                colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name
                On Error GoTo 0
              Next rngChar
            End If
          Next oShp
        End If
      Case Else
        'Do Nothing
    End Select
SkipRange:
On Error GoTo 0
    'Get next linked story (if any)
    Set rngStory = rngStory.NextStoryRange
  Loop Until rngStory Is Nothing
Next rngStory
  'Sort the collection.
  StatusBar = "Sorting Font List"
  Set colFontsUsed = SortCollection(colFontsUsed)
  StatusBar = ""
'Create font list document.
Set oDocList = Documents.Add
With oDocList.Range
  .Text = "There are " & _
      colFontsUsed.Count & " fonts used in the document, as follows:" & vbCr + vbCr
  For lngIndex = 1 To colFontsUsed.Count
   .InsertAfter colFontsUsed(lngIndex) & vbCr
    Next lngIndex
End With
Set oDocList = Nothing
Exit Sub
Err_Handler:
Resume SkipRange
End Sub
Public Function SortCollection(ByVal oCol As Collection) As Collection
Dim arrIndex() As Long
Dim lngCount As Long
Dim i As Long
Dim m As Long
Dim oColSorted As New Collection

lngCount = oCol.Count
If lngCount = 0 Then
  Set SortCollection = New Collection
  Exit Function
End If
'Allocate an index array.
ReDim arrIndex(0 To lngCount - 1) As Long
'Fill the index array.
For i = 0 To lngCount - 1
 arrIndex(i) = i + 1
Next i
'Generate an ordered heap.
For i = lngCount \ 2 - 1 To 0 Step -1
  Heapify oCol, arrIndex, i, lngCount
Next i
'Sort the index array
For m = lngCount To 2 Step -1
  Exchange arrIndex, 0, m - 1
  Heapify oCol, arrIndex, 0, m - 1
Next
For i = 0 To lngCount - 1
  oColSorted.Add oCol.Item(arrIndex(i))
Next  ' fill output collection
Set SortCollection = oColSorted
End Function
Private Sub Heapify(oCol As Collection, arrIndexPasssed() As Long, lngIndex As Long, lngCount As Long)
Dim lngMidCount As Long
Dim i As Long
lngMidCount = lngCount \ 2
Do While lngIndex < lngMidCount
  i = 2 * lngIndex + 1
  If i + 1 < lngCount Then
    If oCol.Item(arrIndexPasssed(i)) < oCol.Item(arrIndexPasssed(i + 1)) Then
      i = i + 1
    End If
  End If
  If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) Then
    Exit Do
  End If
  Exchange arrIndexPasssed, lngIndex, i
  lngIndex = i
Loop
End Sub
Private Sub Exchange(Index() As Long, i As Long, j As Long)
Dim Temp As Long
  Temp = Index(i)
  Index(i) = Index(j)
  Index(j) = Temp
End Sub

In a  web search, I found a macro from a source I've used before here:

http://word.tips.net/T001522_Creating_a_Document_Font_List.html

And a possibly faster method here, which might be worth looking into (the code is way beyond my vba-reading skills):

http://stackoverflow.com/questions/5261108/list-fonts-used-by-a-word-document-faster-method

Good luck,

Pam