Hi asur!
Is there any way of finding out which fonts are called for in a Word 97 document?
Here is a better macro. Try this.
--------------------------------------------------------------------------------
Sub ListFontsInDoc()
'
' FontsInDocList Macro
' Macro created 06.11.30 by zzsido
'
Dim FontList(199) As String
Dim FontCount As Integer
Dim FontName As String
Dim j As Integer, k As Integer, L As Integer
Dim X As Long, Y As Long, lngJunk As Long
Dim FoundFont As Boolean
Dim rngChar As Range
Dim strFontList As String
Dim rngStory As Word.Range
Dim oShp As Shape
FontCount = 0
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
' Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
For Each rngChar In ActiveDocument.Characters
FontName = rngChar.Font.Name
FoundFont = False
For j = 1 To FontCount
If FontList(j) = FontName Then FoundFont = True
Next j
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
Next rngChar
On Error Resume Next
Select Case rngStory.StoryType
Case 5, 6, 7, 8, 9, 10, 11
If rngStory.Characters.Count > 0 Then
For Each rngChar In rngStory.Characters
FontName = rngChar.Font.Name
FoundFont = False
For j = 1 To FontCount
If FontList(j) = FontName Then FoundFont = True
Next j
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
Next rngChar
End If
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.TextRange.Characters.Count > 0 Then
For Each rngChar In oShp.TextFrame.TextRange.Characters
FontName = rngChar.Font.Name
FoundFont = False
For j = 1 To FontCount
If FontList(j) = FontName Then FoundFont = True
Next j
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
Next rngChar
End If
Next
End If
Case Else
End Select
On Error GoTo 0
' Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
If ActiveDocument.Shapes.Count > 0 Then
For Each oShp In ActiveDocument.Shapes
If Left(oShp.Name, 7) = "WordArt" Then
FontName = oShp.TextEffect.FontName
FoundFont = False
For j = 1 To FontCount
If FontList(j) = FontName Then FoundFont = True
Next j
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
End If
Next oShp
End If
' sort the list
StatusBar = "Sorting Font List"
For j = 1 To FontCount - 1
L = j
For k = j + 1 To FontCount
If FontList(L) > FontList(k) Then L = k
Next k
If j <> L Then
FontName = FontList(j)
FontList(j) = FontList(L)
FontList(L) = FontName
End If
Next j
StatusBar = ""
' put in new document
Documents.Add
Selection.TypeText Text:="There are " & FontCount & " fonts used " _
& "in the document (except inserted symbols), as follows:"
Selection.TypeParagraph
Selection.TypeParagraph
For j = 1 To FontCount
Selection.TypeText Text:=FontList(j)
Selection.TypeParagraph
Next j
End Sub
--------------------------------------------------------------------------------
Regards,
zzsido