Find list of font types in a document by Word macro.

[Sam1085]

Hi,

I tried to create a macro to identify list of font types in a document. While searching this topic on Google, I got found a similar macro to do this thing and I have customized that macro for my work. But the concern is this macro takes too much time to complete the process (< 20min for some documents).

Code: Select all

Sub FindFontTypes()
Dim StrFntArr As String
    StrFntArr = GetFonts(ActiveDocument)
    MsgBox "The following font colors are used in this document:" & vbNewLine & StrFntArr
End Sub
 
Private Function GetFonts(ByVal oDocument As Document) As String
    Dim oParagraph      As Paragraph
    Dim i               As Integer
    Dim oWord           As Words
    Dim sFontType       As String
    Dim StrFntArr       As String
    
    For Each oParagraph In oDocument.Paragraphs
        For i = 1 To oParagraph.Range.Characters.Count
            sFontType = oParagraph.Range.Characters(i).Font.Name
            If InStr(1, StrFntArr, sFontType) = 0 Then
                StrFntArr = StrFntArr & sFontType & vbNewLine
            End If
        Next
    Next
    GetFonts = StrFntArr
End Function

Is there any alternative way to do the same thing. I was thinking about the following process. But I have no idea about how to do in VBA.
1. Find first character font type.
2. Record the font type as string.
3. Hide all characters in that font. (loop 1,2,3 steps)
4. If all characters got hide then display font type as a massage box.

Appreciate your help to develop this macro. Thank you!

[HansV]

Try this:

Code: Select all

Sub FindFontNames()
    Dim varFont As Variant
    Dim strFonts As String
    Application.ScreenUpdating = False
    strFonts = "Fonts in document:"
    For Each varFont In FontNames
        With ActiveDocument.Content.Find
            .ClearFormatting
            .Text = ""
            .Replacement.ClearFormatting
            .Replacement.Text = ""
            .MatchWholeWord = False
            .MatchWildcards = False
            .Font.Name = varFont
            If .Execute Then
                strFonts = strFonts & vbCr & varFont
            End If
        End With
    Next varFont
    Application.ScreenUpdating = True
    MsgBox strFonts
End Sub

It misses the body font, but you can easily add that.

[HansV]

Warning: the code only looks at the main document; it doesn't look at headers, footers, text boxes, footnotes, comments, etc.

[Sam1085]

Thank you Hans for quick reply,

I tried the above code. Seems like that code automatically ignore some fonts. Could you check with the attached test document.

img1.png

Test Document.docx

Thank you!

[HansV]

Apparently there is a bug in finding Fonts - Calibri, Times New Roman and Cambria are clearly present, and Impact is nowhere to be found...
I'm finding more and more bugs in Word VBA.

Perhaps Macropod can write a macro for you based on your suggestion; I tried and failed.

[Sam1085]

No prob Hans; Thank you and I appreciate your efforts.

I manually changed ''Impact' font type to all paragraph characters. That's why the msg box display 'Impact' font.

impact font type.png

Previously Macropod created a code for find font color (Similar with this) in this thread.
http://www.eileenslounge.com/viewtopic. ... 1&start=20" onclick="window.open(this.href);return false;

But I haven't enough knowledge in VBA to customize it to this requirement.

[HansV]

I tried to do that, but it didn't work...

[macropod]

Try:

Code: Select all

Sub TestDocFonts()
Dim ListFont As Variant, StrFnt As String, StrInFnt As String, StrNoFnt As String
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Format = True
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "[!^13]{1,}"
    With .Replacement
      .ClearFormatting
      .Text = "^&"
      .Font.Hidden = True
    End With
    .Execute Replace:=wdReplaceAll
    .Font.Hidden = True
    .Replacement.Font.Hidden = False
    For Each ListFont In FontNames
      .Font.NameAscii = ListFont
      .Execute Replace:=wdReplaceAll
      If .Found Then StrInFnt = StrInFnt & vbCr & .Font.NameAscii
      DoEvents
    Next ListFont
    .Font.NameAscii = ""
    .Execute
  End With
  Do While .Find.Found
    StrFnt = .Characters.First.Font.NameAscii
    StrNoFnt = StrNoFnt & vbCr & StrFnt
    With .Find
      .Font.NameAscii = StrFnt
      .Execute Replace:=wdReplaceAll
    End With
    If .Information(wdWithInTable) = True Then
      If .End = .Cells(1).Range.End - 1 Then
        .End = .Cells(1).Range.End
        .Collapse wdCollapseEnd
        If .Information(wdAtEndOfRowMarker) = True Then
          .End = .End + 1
        End If
      End If
    End If
    If .End >= ActiveDocument.Range.End - 1 Then Exit Do
    .Collapse wdCollapseEnd
    .Find.Execute
    DoEvents
  Loop
End With
Application.ScreenUpdating = False
MsgBox "The following fonts were found in the document, and on the system:" & StrInFnt
MsgBox "The following fonts were found in the document, but not on the system:" & StrNoFnt
End Sub

The main problem with the previous code in this thread is that it's trying to retrieve .Font.Name instead of .Font.NameAscii from the FontNames collection.

Note: Paragraph breaks are not tested, because of problems Word's F/R has with paragraph breaks preceding tables.

[HansV]

Hi Paul,

When I run your code against Sampath's sample document, it reports Times New Roman and +Body (=Calibri), but it misses Arial and Cambria.

[HansV]

The problem with Cambria is that it has been applied as +Headings, just like Calibri has been applied as +Body. If you apply Cambria itself, the font will be found by the following version of the code:

Code: Select all

Sub FindFontNames()
    Dim varFont As Variant
    Dim strFonts As String
    Application.ScreenUpdating = False
    strFonts = "Fonts in document:"
    For Each varFont In FontNames
        With ActiveDocument.Content.Find
            .ClearFormatting
            .Text = ""
            .Replacement.ClearFormatting
            .Replacement.Text = ""
            .MatchWholeWord = False
            .MatchWildcards = False
            .Font.NameAscii = varFont
            If .Execute Then
                strFonts = strFonts & vbCr & varFont
            End If
        End With
    Next varFont
    Application.ScreenUpdating = True
    MsgBox strFonts
End Sub

S1632.png

[macropod]

Give this version a whirl:

Code: Select all

Sub TestDocFonts()
Application.ScreenUpdating = False
Dim StrFnt As Variant, StrFnts As String, StrInFnt As String, StrNoFnt As String, Fnt As Font
For Each StrFnt In FontNames
  StrFnts = StrFnts & "'" & StrFnt
Next
StrFnts = StrFnts & "'"
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Format = True
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "[!^13]{1,}"
    With .Replacement
      .ClearFormatting
      .Text = "^&"
      .Font.Hidden = True
    End With
    .Execute Replace:=wdReplaceAll
    .Text = "?"
    .Font.Hidden = True
    .Execute
  End With
  Do While .Find.Found
    Set Fnt = .Font
    With Fnt
      If InStr(StrFnts, "'" & .Name & "'") > 0 Then
        StrInFnt = StrInFnt & vbCr & .Name
      Else
        StrNoFnt = StrNoFnt & vbCr & .Name
      End If
    End With
    With .Duplicate.Find
      .Font.Hidden = True
      .Replacement.Font.Hidden = False
      .Font.Name = Fnt.Name
      .Execute Replace:=wdReplaceAll
      .Font.Name = Fnt.Name & Fnt.NameAscii
      .Execute Replace:=wdReplaceAll
      .Font.Name = ""
      .Font.NameAscii = Fnt.NameAscii
      .Execute Replace:=wdReplaceAll
    End With
    .Find.Execute
    DoEvents
  Loop
End With
Application.ScreenUpdating = True
MsgBox "The following fonts were found in the document, and on the system:" & StrInFnt
MsgBox "The following fonts were found in the document, but not on the system:" & StrNoFnt
End Sub

[HansV]

That looks good, Paul. Thanks!

[Sam1085]

Hi Paul and Hans,

Thank you both of you . Final code works as I expected. I have customized that code to get header / footer font types also.

[Elden]

Nice, what if it can't identify the font?

[HansV]

Welcome to Eileen's Lounge!
Have you tried the latest version of the code?

[macropod]

Nice, what if it can't identify the font?

Do you have a font it can't identify?