determine which fonts used in Word doc

R

Russ

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
 
J

Jonathan Sachs

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?
Click to expand...

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.
 
J

Jezebel

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
 
J

Jonathan Sachs

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.
 
R

Russ

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
 
R

Russ

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
 
R

Russ

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Welsh Fonts in Oracle database 2
Adding a Large Number of Shapes is Very Slow in Word 2002 9
List of fonts used in a Word doc -- the easy way 1
Calculating the height (in mm) of a text line in Microsoft Word 3
Mac OS X 10.5 and fonts installed by Office 2008 4
"embedding" fonts in Excel 1
Working With Fonts\Character Code\Symbols in VBA 3
Attempting to "Embed" a font in Excel 2003 - Could use help with VBA code 0

Top