Hi Ravi,
that is not a simple thing, I'd think,
but fortunately, there is something in my toolbox.
The following should generate a list of fonts,
which are in the doc, but not in the collection of
the fontnames of the application, including decorative fonts,
Mac-Fonts and just anything.
Note! You must replace "(normaler Text)" by the appropriate
probably english, equivalent. Could be something like
"(normal text)". The result will be in the "direct area"
or "direct window", whatever it may be in English.
Sorry, there is almost no documentation.
You could do that for me ;-)
Ask again, if you need further assistance.
Improvements welcome!
---
Greetings from Bavaria, Germany
Helmut Weber, MVP
"red.sys" & chr(64) & "t-online.de"
Word XP, Win 98
---
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 <> "(normaler Text)" Then ' English equivalent !!!
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
