Results 1 to 7 of 7
  1. #1
    2 Star Lounger
    Join Date
    Aug 2011
    Posts
    112
    Thanks
    35
    Thanked 3 Times in 3 Posts

    Macro or method to check document for fonts used along with font size

    I found a couple of macros which will search a document and produce the result showing Fonts used in a document; however, the two I found only show the font name, but not the font sizes.

    http://www.vbaexpress.com/kb/getarticle.php?kb_id=137

    http://word.tips.net/T001522_Creatin...Font_List.html

    Overall, I like the script from VBAE better as it just produces a message box with the results.

    Anybody know a reference where I can find a script which will produce both font name and font size?

  2. #2
    Star Lounger Graham Mayor's Avatar
    Join Date
    Mar 2016
    Location
    Cyprus
    Posts
    68
    Thanks
    0
    Thanked 24 Times in 24 Posts
    The following should list the fonts and their sizes (and not just in the main document body). As it checks each character, it will take some time to run, especially on a large document.
    Code:
    Option Explicit
    
    Public Sub Main()
    Dim sMsg As String
        sMsg = GetFonts(ActiveDocument)
        MsgBox "The fonts in this document are:" & vbNewLine & vbNewLine & sMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    Private Function GetFonts(ByVal oDocument As Document) As String
    
    Dim oParagraph As Paragraph
    Dim i As Integer
    Dim sMsg As String
    Dim sFontType As String
    Dim sFontSize As String
    Dim Coll As New Collection
    Dim oStory As Range
    Dim Arr() As Variant
    
        For Each oStory In oDocument.StoryRanges
            For Each oParagraph In oStory.Paragraphs
                For i = 1 To oParagraph.Range.Characters.Count
                    sFontType = oParagraph.Range.Characters(i).Font.Name
                    sFontSize = oParagraph.Range.Characters(i).Font.Size & " pts."
                    If InStr(1, sMsg, sFontType & Chr(32) & sFontSize) = 0 Then
                        sMsg = sMsg & sFontType & Chr(32) & sFontSize & vbNewLine
                        Coll.Add sFontType & Chr(32) & sFontSize
                    End If
                    DoEvents
                Next i
            Next oParagraph
            If oStory.StoryType <> wdMainTextStory Then
                While Not (oStory.NextStoryRange Is Nothing)
                    Set oStory = oStory.NextStoryRange
                    For Each oParagraph In oStory.Paragraphs
                        For i = 1 To oParagraph.Range.Characters.Count
                            sFontType = oParagraph.Range.Characters(i).Font.Name
                            sFontSize = oParagraph.Range.Characters(i).Font.Size & " pts."
                            If InStr(1, sMsg, sFontType & Chr(32) & sFontSize) = 0 Then
                                sMsg = sMsg & sFontType & Chr(32) & sFontSize & vbNewLine
                                Coll.Add sFontType & Chr(32) & sFontSize
                            End If
                            DoEvents
                        Next i
                    Next oParagraph
                Wend
            End If
        Next oStory
        Arr = toArray(Coll)
        QuickSort Arr
        sMsg = ""
        For i = LBound(Arr) To UBound(Arr)
            sMsg = sMsg & Arr(i)
            If i < UBound(Arr) Then sMsg = sMsg & vbNewLine
        Next i
        GetFonts = sMsg
    lbl_Exit:
        Set Coll = Nothing
        Set oStory = Nothing
        Set oParagraph = Nothing
        Exit Function
    End Function
    
    Private Function toArray(ByVal Coll As Collection) As Variant
    Dim Arr() As Variant
    Dim i As Long
        ReDim Arr(1 To Coll.Count) As Variant
        For i = 1 To Coll.Count
            Arr(i) = Coll(i)
        Next
        toArray = Arr
    lbl_Exit:
        Exit Function
    End Function
    
    Private Sub QuickSort(vArray As Variant, _
                          Optional lng_Low As Long, _
                          Optional lng_High As Long)
    Dim vPivot As Variant
    Dim vTmp_Swap As Variant
    Dim tmp_Low As Long
    Dim tmp_High As Long
    
        If lng_High = 0 Then
            lng_Low = LBound(vArray)
            lng_High = UBound(vArray)
        End If
    
        tmp_Low = lng_Low
        tmp_High = lng_High
        vPivot = vArray((lng_Low + lng_High) \ 2)
        While (tmp_Low <= tmp_High)
            While (vArray(tmp_Low) < vPivot And tmp_Low < lng_High)
                tmp_Low = tmp_Low + 1
            Wend
            While (vPivot < vArray(tmp_High) And tmp_High > lng_Low)
                tmp_High = tmp_High - 1
            Wend
            If (tmp_Low <= tmp_High) Then
                vTmp_Swap = vArray(tmp_Low)
                vArray(tmp_Low) = vArray(tmp_High)
                vArray(tmp_High) = vTmp_Swap
                tmp_Low = tmp_Low + 1
                tmp_High = tmp_High - 1
            End If
        Wend
        If (lng_Low < tmp_High) Then QuickSort vArray, lng_Low, tmp_High
        If (tmp_Low < lng_High) Then QuickSort vArray, tmp_Low, lng_High
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - Word MVP
    http://www.gmayor.com

  3. #3
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Getting a list of fonts used is easy enough, though I don't regard the code in either of your links especially efficient for a large document - a Find loop for all installed & embedded fonts would be more efficient - but, once a given range in a nominated font uses more than one point size, there are 3,166 possibilities per font - all the way from 1pt to 1584pt in 0.5pt increments - that might need testing...
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  4. #4
    2 Star Lounger
    Join Date
    Aug 2011
    Posts
    112
    Thanks
    35
    Thanked 3 Times in 3 Posts
    @ Graham,

    Thank you for the code. It took a fair amount of time to run and it produces one font with three sizes. In that one page is one font and one size. I'm going to do some more testing today at work.

    @ Paul,

    I'm setting up a .dotm so hopefully we don't get to squirrely and font/size usage. We use NTR 12 for the body of our documents but tables within the document are supposed to be NTR 10. Most likely one document will be any where from 8 pages to max, 100 pages.

  5. #5
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Try the following macro. It will test all installed fonts and their sizes from 1 to 72pt - you can change that by editing the 'For i = 2 To 144' line. For me it took 53 seconds on a 230 page document with 3 fonts & 8 point sizes between them.
    Code:
    Sub TestDocFonts()
    Application.ScreenUpdating = False
    Dim ListFont As Variant, i As Long, j As Long
    Dim StrFonts As String, StrPoints As String, StrOut As String
    With ActiveDocument
      With .Range
        With .Find
          .ClearFormatting
          .Format = True
          .Forward = True
          .Wrap = wdFindContinue
          For Each ListFont In FontNames
            .Font.NameAscii = ListFont
            .Execute
            If .Found Then StrFonts = StrFonts & vbCr & ListFont
          Next
          .ClearFormatting
          For i = 2 To 144
            .Font.Size = i / 2
            .Execute
            If .Found Then StrPoints = StrPoints & vbCr & i / 2
          Next
          For i = 1 To UBound(Split(StrFonts, vbCr))
            StrOut = StrOut & Split(StrFonts, vbCr)(i)
            For j = 1 To UBound(Split(StrPoints, vbCr))
              .Font.NameAscii = Split(StrFonts, vbCr)(i)
              .Font.Size = Split(StrPoints, vbCr)(j)
              .Execute
              If .Found Then StrOut = StrOut & vbTab & Split(StrPoints, vbCr)(j)
            Next
            StrOut = StrOut & vbCr
          Next
        End With
      End With
    End With
    Application.ScreenUpdating = True
    MsgBox StrOut
    End Sub
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  6. #6
    2 Star Lounger
    Join Date
    Aug 2011
    Posts
    112
    Thanks
    35
    Thanked 3 Times in 3 Posts
    Hi Paul,

    This is incredibly efficient and quick. On my test document it ran it about 2 second where the other macros where about 45 seconds on the same document.

    Thank you

  7. #7
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    I should mention that Graham's code tests headers/footers, textboxes, etc., as well as the document body, whereas mine only tests the latter. One could tweak my code to test all storyranges, too, without a huge impact on the execution time, but at least with the code I've posted you know which part of the document to look in for a given font & point size.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •