List fonts in a document

  • Thread starter Thread starter Guest
  • Start date Start date
Hi,
if you have the necessary VBA knowledge,
you should get this to work for you.
I'm sorry for the missing documentation.
There might be complications, if wordperfect
fonts are installed on your system.
------------------------------------
Sub FontNames()
' wdStatisticCharacters = 3
Dim oDcm As Document
Dim oPrg As Paragraph
Dim oChr As Object
Dim oRng As Range
Dim lCh1 As Long
Dim lCh2 As Long
Dim l As Long
Dim m As Long
Dim bFnd As Boolean
ReDim arDocFnt(0) As String
ReDim arAppFnt(Application.FontNames.Count) As String
Dim sFnt As Variant
l = 0
For Each sFnt In Application.FontNames
l = l + 1
arAppFnt(l) = sFnt
Next

Set oDcm = ActiveDocument
Set oRng = oDcm.Range

oDcm.SaveAs "c:\test\Symbol-01.doc"
oDcm.SaveAs "c:\test\Symbol-03.doc"
Resetsearch
' Application.Visible = Not Application.Visible
For Each oPrg In oDcm.Paragraphs
If oPrg.Range.Text = Chr(13) Then
oPrg.Range.Delete
End If
Next
' ---
For Each oChr In oDcm.Characters
If Asc(oChr) = 40 Or Asc(oChr) = 63 Then
oChr.Select
sFnt = Dialogs(wdDialogInsertSymbol).Font
If sFnt <> "(normal text)" Then
Selection.Font.Name = sFnt
Else
Selection.Range.Delete
End If
End If
Next
' ---
lCh2 = lCh1
While oRng.End > 1
sFnt = oDcm.Characters(1).Font.Name
bFnd = False
' ---
For l = 0 To UBound(arDocFnt)
If arDocFnt(l) = sFnt Then
bFnd = True
Exit For
End If
Next
If bFnd = False Then
ReDim Preserve arDocFnt(UBound(arDocFnt) + 1)
arDocFnt(UBound(arDocFnt)) = sFnt
End If
' ---
lCh1 = oDcm.ComputeStatistics(3)
With oRng.Find
.Text = ""
.Format = True
.Font.Name = sFnt
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
lCh2 = oDcm.ComputeStatistics(3)
If lCh1 = lCh2 Then
Selection.WholeStory
Selection.Collapse
While sFnt = Selection.Font.Name
Selection.Delete
Wend
End If
Wend
' ---
'Application.Visible = Not Application.Visible
For l = 1 To UBound(arDocFnt)
bFnd = False
For m = 1 To UBound(arAppFnt)
If arDocFnt(l) = arAppFnt(m) Then
bFnd = True
End If
Next
If bFnd = False Then
Debug.Print arDocFnt(l)
End If
Next

Stop
ActiveDocument.Save
ActiveDocument.Close
Documents.Open "c:\test\Symbol-01.doc"

End Sub
---
Sub Resetsearch()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
--------------------------------------
Otherwise, I'd suggest asking in
public.word.vba.general

Greetings from Bavaria, Germany
Helmut Weber, MVP WordVBA
"red.sys" & chr(64) & "t-online.de"
Word 2002, Windows 2000
 
If you open the document using the "Recover Text from Any File" setting for
"Files of type" in the File Open dialog, you'll find a listing of fonts
toward the end. Be careful not to save the document in this form, and if you
have Word 2000 or earlier, be sure to change "Files of type" back to your
usual setting.

--
Suzanne S. Barnhill
Microsoft MVP (Word)
Words into Type
Fairhope, Alabama USA

Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.
 
Back
Top