checking for fonts in document   

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.

date: Sat, 16 Aug 2008 07:58:24 -0700 (PDT)   author:   macroapa

RE: checking for fonts in document   

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

"macroapa" wrote:

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

date: Sat, 16 Aug 2008 10:36:00 -0700   author:   StevenM stevencraigmiller(at)comcast(dot)net

Re: checking for fonts in document   

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 wrote:
> 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
>
> "macroapa" wrote:
>
>> 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.

-- 
Greg Maxey -  Word MVP

My web site http://gregmaxey.mvps.org
Word MVP web site http://word.mvps.org

date: Sat, 16 Aug 2008 14:48:30 -0400   author:   Greg Maxey RrOMEOgOLF

Re: checking for fonts in document   

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

date: Sat, 16 Aug 2008 12:40:01 -0700   author:   StevenM stevencraigmiller(at)comcast(dot)net

Re: checking for fonts in document   

On 16 Aug, 20:40, StevenM <stevencraigmiller(at)comcast(dot)net>
wrote:
> 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

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.

date: Sat, 16 Aug 2008 13:12:41 -0700 (PDT)   author:   macroapa