checking for fonts in document

[macroapa]

Hi,

I have a list of fonts and what I want to do is run some code over the
open document to see if it contains any fonts that are NOT in my list
and then return TRUE if it only contains fonts in my list of
acceptable fonts and FALSE if it contains other fonts,

I guess I need to hold the 'acceptable' fonts in some form of array
and then have a loop that checks the first font in the document to see
if it is in the array and if that passes then move onto the next font
it finds in the document.

I reckon I could probably handle the checking within an array, but I
dont quite no how to find out what fonts are in the open document in
the first place.

Any help would be much appreciated.

Thanks.

 

[StevenM]

To: macroapa,

I haven't done a lot of testing on this, so let me know how they work. But I
think this is the right idea. The first function "IsFontInUseInDoc" calls the
second function "IsFontInRange."

Private Function IsFontInUseInDoc(ByVal sFontName As String, ByVal oDoc As
Document) As Boolean
Dim oRange As Range
Dim bReturn As Boolean

bReturn = False
For Each oRange In oDoc.StoryRanges
If IsFontInRange(sFontName, oRange) = True Then
bReturn = True
End If
Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange
If IsFontInRange(sFontName, oRange) = True Then
bReturn = True
End If
Loop
Next oRange
IsFontInUseInDoc = bReturn
End Function

Private Function IsFontInRange(ByVal sFontName As String, ByVal oRange As
Range) As Boolean
oRange.Collapse Direction:=wdCollapseStart
With oRange.Find
.ClearFormatting
.Font.Name = sFontName
.Forward = True
.Format = True
.Text = ""
.Execute
End With
IsFontInRange = oRange.Find.Found
End Function

And then you need something like the following to run the above two functions.

Sub TestIsFontInUseInDoc()
Const FontList = "Garamond,Arial,SimSun,Times New Roman"
Dim vFontList As Variant
Dim i As Long

vFontList = Split(FontList, ",")
For i = LBound(vFontList) To UBound(vFontList)
MsgBox vFontList(i) & " is " & IsFontInUseInDoc(vFontList(i),
ActiveDocument)
Next i
End Sub

Steven Craig Miller

 

[Greg Maxey]

Steven,

Interesting code, but I am not sure that it is a solution to the OPs
problem. Your code will evaluate your list of fonts and indicate if that
font "is" or "is not" contained in the document. I think the OP wants to
look at the document and determine if it contains any font that "is not" on
his list.

I have probably done less testing than you ;-), but I think this (clunky as
it may be) may be close to a solution.

Sub ScratchMacro()
'Return true if the doc contains only acceptable fonts.
MsgBox CheckForFonts
End Sub

Function CheckForFonts() As Boolean
Dim oRng As Word.Range
Dim vFontNames()
Dim i As Long
Dim FontList As New Collection
Dim oChr As Range
Dim pTemp As String
CheckForFonts = True
'Collect the acceptable font names
vFontNames = Array("Times New Roman", "Arial", "Courier New")
'Create a collection of the acceptable font names
For i = 0 To UBound(vFontNames)
FontList.Add vFontNames(i), vFontNames(i)
Next i
'Since "font" is an attribute that can be applied to
'individual characters, or even spaces, I suppose
'you will have to check each one.
For Each oRng In ActiveDocument.StoryRanges
For Each oChr In oRng.Characters
On Error GoTo Err_Handler
'If the font name is not in the collection, this line throws an error
*****
pTemp = FontList.Item(oChr.Font.Name)
On Error GoTo 0
Next oChr
Do While Not (oRng.NextStoryRange Is Nothing)
Set oRng = oRng.NextStoryRange
For Each oChr In oRng.Characters
On Error GoTo Err_Handler
pTemp = FontList.Item(oChr.Font.Name)
On Error GoTo 0
Next oChr
Loop
Next oRng
Exit Function
Err_Handler:
'***** Capture that error and process the unacceptable font.
If Err.Number = 5 And CheckForFonts Then
CheckForFonts = False
oChr.HighlightColorIndex = wdYellow
Resume Next
ElseIf Err.Number = 5 Then
oChr.HighlightColorIndex = wdYellow
Resume Next
Else
MsgBox Err.Number & " " & Err.Description
End
End If
End Function

 

[StevenM]

Greg Maxey wrote: << ... I am not sure that it is a solution to the OPs
problem. Your code will evaluate your list of fonts and indicate if that
font "is" or "is not" contained in the document. I think the OP wants to
look at the document and determine if it contains any font that "is not" on
his list. >>

Point taken.

Attempt number 2:

Sub ListFontsInDoc()
Dim sFonts As String
sFonts = FindFontsInUseInDoc(ActiveDocument)
sFonts = Replace(sFonts, ",", vbCr)
MsgBox sFonts
End Sub

Private Function FindFontsInUseInDoc(ByVal oDoc As Document) As String
Dim oRange As Range
Dim sFonts As String

For Each oRange In oDoc.StoryRanges
sFonts = FindFontsInRange(oRange, sFonts)
Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange
sFonts = FindFontsInRange(oRange, sFonts)
Loop
Next oRange
If Len(sFonts) > 0 Then
sFonts = Left(sFonts, Len(sFonts) - 1)
End If
FindFontsInUseInDoc = sFonts
End Function

Private Function FindFontsInRange(ByVal oRange As Range, ByVal sFonts As
String) As String
Dim oChar As Range
For Each oChar In oRange.Characters
If InStr(1, sFonts, oChar.Font.Name, vbTextCompare) = 0 Then
sFonts = sFonts & oChar.Font.Name & ","
End If
Next oChar
FindFontsInRange = sFonts
End Function

Steven Craig Miller

 

[macroapa]

Greg Maxey wrote: << ... I am not sure that it is a solution to the OPs

problem.  Your code will evaluate your list of fonts and indicate if that
font "is" or "is not" contained in the document.  I think the OP wants to
look at the document and determine if it contains any font that "is not" on
his list. >>

Point taken.

Attempt number 2:

Sub ListFontsInDoc()
    Dim sFonts As String
    sFonts = FindFontsInUseInDoc(ActiveDocument)
    sFonts = Replace(sFonts, ",", vbCr)
    MsgBox sFonts
End Sub

Private Function FindFontsInUseInDoc(ByVal oDoc As Document) As String
    Dim oRange As Range
    Dim sFonts As String

    For Each oRange In oDoc.StoryRanges
        sFonts = FindFontsInRange(oRange, sFonts)
        Do While Not (oRange.NextStoryRange Is Nothing)
            Set oRange = oRange.NextStoryRange
            sFonts = FindFontsInRange(oRange, sFonts)
        Loop
    Next oRange
    If Len(sFonts) > 0 Then
        sFonts = Left(sFonts, Len(sFonts) - 1)
    End If
    FindFontsInUseInDoc = sFonts
End Function

Private Function FindFontsInRange(ByVal oRange As Range, ByVal sFonts As
String) As String
    Dim oChar As Range
    For Each oChar In oRange.Characters
        If InStr(1, sFonts, oChar.Font.Name, vbTextCompare) = 0Then
            sFonts = sFonts & oChar.Font.Name & ","
        End If
    Next oChar
    FindFontsInRange = sFonts
End Function

Steven Craig Miller

Thanks both, really wasn't expecting a complete solution to my
problem, so that's great. I haven't tried them out yet, but looking
through what you've posted, I'm quite confident now.

Thanks again.