determine which fonts used in Word doc

Thread view:

Enable EMail Alerts

Start New Thread

Thread rating:

Russ - 13 Nov 2005 15:37 GMT

Y'all: I took some code posted here few years back and expanded it so
that I can highlight the characters in my Word document that are of
undesireable font type. This works but is SLOW. How can I determine
all font types used in a Word document without going through each
character?

russ

Public Sub BSLFontMark()
'Macro created by rwpatter
' Characters with incompatible font are highlighted in yellow.
Dim GoodFontList(39) As String
Dim FontName As String
Dim BSL_OK As Boolean
Dim NoBadFontFound As Boolean
Dim i As Integer
Dim V As Long, Y As Long, X As Long, Z As Long
Dim rngChar As Range
NoBadFontFound = True
'list of fonts that are allowed in BSL database
GoodFontList(1) = "Arial"
GoodFontList(2) = "Arial Black"
GoodFontList(3) = "Arial Narrow"
GoodFontList(4) = "Book Antiqua"
GoodFontList(5) = "Bookman Old Style"
GoodFontList(6) = "Century Gothic"
GoodFontList(7) = "Comic Sans MS"
GoodFontList(8) = "Courier New"
GoodFontList(9) = "Estrangelo Edessa"
GoodFontList(10) = "Franklin Gothic Medium"
GoodFontList(11) = "Garamond"
GoodFontList(12) = "Gautami"
GoodFontList(13) = "Georgia"
GoodFontList(14) = "Haettenschweiler"
GoodFontList(15) = "Impact"
GoodFontList(16) = "Latha"
GoodFontList(17) = "Lucida Console"
GoodFontList(18) = "Lucida Sans Unicode"
GoodFontList(19) = "Mangal"
GoodFontList(20) = "Math Ext"
GoodFontList(21) = "Monotype Corsiva"
GoodFontList(22) = "MS Outlook"
GoodFontList(23) = "MT Extra"
GoodFontList(24) = "Mv Boli"
GoodFontList(25) = "Platino Linotype"
GoodFontList(26) = "Raavi"
GoodFontList(27) = "Shruti"
GoodFontList(28) = "Sylfaen"
GoodFontList(29) = "Symbol"
GoodFontList(30) = "Tahoma"
GoodFontList(31) = "Times New Roman"
GoodFontList(32) = "Trebuchet MS"
GoodFontList(33) = "Trebuchet MS"
GoodFontList(34) = "Tunga"
GoodFontList(35) = "Verdana"
GoodFontList(36) = "Webdings"
GoodFontList(37) = "WingDings"
GoodFontList(38) = "Wingdings 2"
GoodFontList(39) = "Wingdings 3"
Y = 0
Z = 0
X = ActiveDocument.Characters.Count
' For-Next loop through every character
For Each rngChar In ActiveDocument.Characters
Y = Y + 1
FontName = rngChar.Font.Name
i = 1
BSL_OK = False
Do Until i = 40
If GoodFontList(i) = FontName Then
BSL_OK = True 'font is a BSL good font
End If
i = i + 1
Loop
If Not BSL_OK And FontName <> "" Then 'Fontname ""
rngChar.HighlightColorIndex = wdYellow
Z = Y 'marks last place a bad font found
V = V + 1 'keeps up with count of bad font chars found
NoBadFontFound = False
End If
StatusBar = Format((Y / X), "0%") 'display status in %
Next rngChar

Selection.SetRange Start:=Z, End:=Z
If NoBadFontFound Then
MsgBox "Congratulations, No BSL incompatible fonts found, document OK
for BSL entry."
Else
MsgBox V & " BSL font incompatible characters found!" & vbCrLf & vbCrLf
& "The text I have highlighted in Yellow is incompatible with the BSL.
Change font type."
End If
End Sub

Reply to this Message

Jonathan Sachs - 13 Nov 2005 16:40 GMT

>Y'all: I took some code posted here few years back and expanded it so
>that I can highlight the characters in my Word document that are of
>undesireable font type. This works but is SLOW. How can I determine
>all font types used in a Word document without going through each
>character?

Iterating that per-character loop over the whole document is killing
you. You need an approach that processes more than one character at a
time.

Following is some pseudo code that will solve the problem -- not
necessarily in the most efficient way, but in a fairly straightforward
way. Since it hasn't been tested it naturally may contain errors, but
it's only meant to convey a concept.

nextChar = position of the first character in the document
do while nextChar <= position of the last character in the document
    nextFont = font type of the character at nextChar
    nextRun = next run of characters with font=nextFont
    if nextFont is not a permitted font then
        highlight nextRun
    endif
    nextChar = position of next character after nextRun
loop;

You find the next run of characters with a specified font by doing a
"Find" that specifies a font, but no text. Note that when Find is used
in this way it will find only one paragraph at a time, even where
consecutive paragraphs have the same font. Avoid writing code that
will behave badly in that situation.

My email address is LLM041103 at earthlink dot net.

Reply to this Message

Jonathan Sachs - 14 Nov 2005 17:43 GMT

One further thought: be sure to highlight unwanted fonts with some
property that is distinguishable on whitespace, such as strikethrough
or background color. Otherwise you will never know if a whitespace
character alone is in an unwanted font.

My email address is LLM041103 at earthlink dot net.

Reply to this Message

Russ - 19 Nov 2005 19:45 GMT

The suggestion to cycle through paragraphs was excellent and has
greatly improved speed. My remaining problem involves highlighting an
isolated space character. If I have a paragraph that only contains
space characters, then the following DOES NOT work.

ActiveDocument.Paragraphs(P).Range.Select
Selection.Range.HighlightColorIndex = wdYellow

How can I highlight a space character?

It works fine if there are normal characters on either side of the
space that are to be highlighted too. But, if I just have a sentence
with spaces only it does not highlight.

russ

Reply to this Message

Russ - 19 Nov 2005 20:17 GMT

Below is latest draft of the macro. I tested it some and it is
ridiculously slow on documents with lots of tables. It zips through
normal text documents - something about the tables really slows it up.
Any ideas on speed improvement there?

russ

ublic Sub BSLFontReview()
'Macro created by rwpatter
'ver 11/19/2005 (rewrite to improve speed)
' Characters with incompatible font are highlighted in yellow.
Dim GoodFontList(39) As String
Dim FontName As String
Dim BSL_OK As Boolean
Dim NoBadFontFound As Boolean
Dim i As Integer
Dim P As Long
Dim rngChar As Range
NoBadFontFound = True
'list of fonts that are allowed in BSL provided by Angela Peacock
GoodFontList(1) = "Arial"
GoodFontList(2) = "Arial Black"
GoodFontList(3) = "Arial Narrow"
GoodFontList(4) = "Book Antiqua"
GoodFontList(5) = "Bookman Old Style"
GoodFontList(6) = "Century Gothic"
GoodFontList(7) = "Comic Sans MS"
GoodFontList(8) = "Courier New"
GoodFontList(9) = "Estrangelo Edessa"
GoodFontList(10) = "Franklin Gothic Medium"
GoodFontList(11) = "Garamond"
GoodFontList(12) = "Gautami"
GoodFontList(13) = "Georgia"
GoodFontList(14) = "Haettenschweiler"
GoodFontList(15) = "Impact"
GoodFontList(16) = "Latha"
GoodFontList(17) = "Lucida Console"
GoodFontList(18) = "Lucida Sans Unicode"
GoodFontList(19) = "Mangal"
GoodFontList(20) = "Math Ext"
GoodFontList(21) = "Monotype Corsiva"
GoodFontList(22) = "MS Outlook"
GoodFontList(23) = "MT Extra"
GoodFontList(24) = "Mv Boli"
GoodFontList(25) = "Platino Linotype"
GoodFontList(26) = "Raavi"
GoodFontList(27) = "Shruti"
GoodFontList(28) = "Sylfaen"
GoodFontList(29) = "Symbol"
GoodFontList(30) = "Tahoma"
GoodFontList(31) = "Times New Roman"
GoodFontList(32) = "Trebuchet MS"
GoodFontList(33) = "Trebuchet MS"
GoodFontList(34) = "Tunga"
GoodFontList(35) = "Verdana"
GoodFontList(36) = "Webdings"
GoodFontList(37) = "WingDings"
GoodFontList(38) = "Wingdings 2"
GoodFontList(39) = "Wingdings 3"
' For-Next loop through every paragraph
For P = 1 To ActiveDocument.Paragraphs.Count
FontName = ActiveDocument.Paragraphs(P).Range.Font.Name
If FontName <> "" Then
'the entire paragraph is same font, check it and move on
BSL_OK = False
i = 1
Do Until i = 40
If GoodFontList(i) = FontName Then
BSL_OK = True 'font is a BSL good font
End If
i = i + 1
Loop
If Not BSL_OK And FontName <> "" Then
ActiveDocument.Paragraphs(P).Range.Select
Selection.Range.HighlightColorIndex = wdYellow
NoBadFontFound = False
End If
Else 'the paragraph has different fonts, check by characters now
For Each rngChar In ActiveDocument.Characters
FontName = rngChar.Font.Name
i = 1
BSL_OK = False
Do Until i = 40
If GoodFontList(i) = FontName Then
BSL_OK = True 'font is a BSL good font
End If
i = i + 1
Loop
If Not BSL_OK And FontName <> "" Then
rngChar.HighlightColorIndex = wdYellow 'highlight it
yellow
NoBadFontFound = False
End If
Next rngChar
End If
Next P
If NoBadFontFound Then
MsgBox "Congratulations, No BSL incompatible fonts found, document OK
for BSL entry."
Else
MsgBox "BSL font incompatible characters found!" & vbCrLf & vbCrLf &
"The text I have highlighted in Yellow is incompatible with the BSL.
Change font type."
End If
End Sub

Reply to this Message

Russ - 19 Nov 2005 20:29 GMT

I found an error and have corrected. It still is dog slow on a
document containing tables.

russ

Public Sub BSLFontReview()
'Macro created by rwpatter
'ver 11/19/2005 original version (rewrite of BSLFontCheck to improve
speed)
' Characters with incompatible font are highlighted in yellow.
Dim GoodFontList(39) As String
Dim FontName As String
Dim BSL_OK As Boolean
Dim NoBadFontFound As Boolean
Dim i As Integer
Dim P As Long
Dim rngChar As Range
Dim myChar As Characters
NoBadFontFound = True
'list of fonts that are allowed in BSL provided by Angela Peacock
GoodFontList(1) = "Arial"
GoodFontList(2) = "Arial Black"
GoodFontList(3) = "Arial Narrow"
GoodFontList(4) = "Book Antiqua"
GoodFontList(5) = "Bookman Old Style"
GoodFontList(6) = "Century Gothic"
GoodFontList(7) = "Comic Sans MS"
GoodFontList(8) = "Courier New"
GoodFontList(9) = "Estrangelo Edessa"
GoodFontList(10) = "Franklin Gothic Medium"
GoodFontList(11) = "Garamond"
GoodFontList(12) = "Gautami"
GoodFontList(13) = "Georgia"
GoodFontList(14) = "Haettenschweiler"
GoodFontList(15) = "Impact"
GoodFontList(16) = "Latha"
GoodFontList(17) = "Lucida Console"
GoodFontList(18) = "Lucida Sans Unicode"
GoodFontList(19) = "Mangal"
GoodFontList(20) = "Math Ext"
GoodFontList(21) = "Monotype Corsiva"
GoodFontList(22) = "MS Outlook"
GoodFontList(23) = "MT Extra"
GoodFontList(24) = "Mv Boli"
GoodFontList(25) = "Platino Linotype"
GoodFontList(26) = "Raavi"
GoodFontList(27) = "Shruti"
GoodFontList(28) = "Sylfaen"
GoodFontList(29) = "Symbol"
GoodFontList(30) = "Tahoma"
GoodFontList(31) = "Times New Roman"
GoodFontList(32) = "Trebuchet MS"
GoodFontList(33) = "Trebuchet MS"
GoodFontList(34) = "Tunga"
GoodFontList(35) = "Verdana"
GoodFontList(36) = "Webdings"
GoodFontList(37) = "WingDings"
GoodFontList(38) = "Wingdings 2"
GoodFontList(39) = "Wingdings 3"
' For-Next loop through every paragraph
For P = 1 To ActiveDocument.Paragraphs.Count
FontName = ActiveDocument.Paragraphs(P).Range.Font.Name
If FontName <> "" Then
'the entire paragraph is same font, check it and move on
BSL_OK = False
i = 1
Do Until i = 40
If GoodFontList(i) = FontName Then
BSL_OK = True 'font is a BSL good font
End If
i = i + 1
Loop
If Not BSL_OK And FontName <> "" Then
ActiveDocument.Paragraphs(P).Range.Select
Selection.Range.HighlightColorIndex = wdYellow 'highlight in
yellow
NoBadFontFound = False
End If
Else 'the paragraph has different fonts, check by characters now
For Each rngChar In
ActiveDocument.Paragraphs(P).Range.Characters
FontName = rngChar.Font.Name
i = 1
BSL_OK = False
Do Until i = 40
If GoodFontList(i) = FontName Then
BSL_OK = True 'font is a BSL good font
End If
i = i + 1
Loop
If Not BSL_OK And FontName <> "" Then
rngChar.HighlightColorIndex = wdYellow
NoBadFontFound = False
End If
Next rngChar
End If
Next P
If NoBadFontFound Then
MsgBox "Congratulations, No BSL incompatible fonts found, document OK
for BSL entry."
Else
MsgBox "BSL font incompatible characters found!" & vbCrLf & vbCrLf &
"The text I have highlighted in Yellow is incompatible with the BSL.
Change font type."
End If
End Sub

Reply to this Message

Jezebel - 13 Nov 2005 21:23 GMT

Iterate the paragraphs of the document. For each, check the .Range.Font.Name
property. If this returns a value, then the entire paragraph has that font
and you need check no further. If it is empty the paragraph contains more
than one font: so iterate the words in the paragraph. You need check
characters only when you get to a word for which the font name is empty.

Separately, a quicker way to check if a font name is valid would be to set
up a collection using the valid font names as keys --

Dim pFontList as collection
Set pFontList as new collection
pFontList.Add Item:=True, Key:="Arial"

Function ValidFont(FontName as string) as boolean

on error resume next
ValidFont = pFontList(FontName)
on error goto 0

End Function

> Y'all: I took some code posted here few years back and expanded it so
> that I can highlight the characters in my Word document that are of
[quoted text clipped - 89 lines]
> End If
> End Sub

Reply to this Message