Font Name and respective size

[shreeram.maroo]

Hi,

Can it be possible to get a list of all the fonts and its respective size being used in the document.
Like : Times new roman - size 11, times new roman - size 10, Arial - 12 and Arial -10

Thanks
Shreeram

[HansV]

The following macro, originally from Greg Maxey, will list all fonts except those marked (Body) or (Headings). Starting with Word 2007, Microsoft has intentionally made it very difficult to find those fonts using VBA.

Code: Select all

Sub FindAllFonts()
    Dim lngFontIndex As Long
    Dim strName As String
    Dim strReturn As String
    Dim oOutputDoc As Document
    Dim oRng As Range
    Dim oChr As Range
    Dim oCol As New Collection
    Dim lngIndex As Long
    Application.ScreenUpdating = False
    For lngFontIndex = 1 To FontNames.Count
        strName = FontNames(lngFontIndex)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            .ClearFormatting
            .Text = ""
            .ClearFormatting
            .Font.Name = strName
            .Forward = True
            .Format = True
            .Wrap = wdFindStop
            Do While .Execute
                oRng.Select
                On Error Resume Next
                If oRng.Font.Size = 9999999 Then
                    For Each oChr In oRng.Characters
                        oCol.Add strName & " - " & oChr.Font.Size, strName & " - " & oChr.Font.Size
                    Next oChr
                Else
                    oCol.Add strName & " - " & oRng.Font.Size, strName & " - " & oRng.Font.Size
                End If
                On Error GoTo 0
                oRng.Collapse wdCollapseEnd
                Debug.Print ActiveDocument.Range.End
                If oRng.End + 1 = ActiveDocument.Range.End Then GoTo NextFont
            Loop
        End With
NextFont:
    Next lngFontIndex
Output:
    For lngIndex = 1 To oCol.Count
        strReturn = strReturn & oCol(lngIndex) & vbCr
    Next lngIndex
    Set oOutputDoc = Documents.Add
    oOutputDoc.Range.Text = strReturn
    Application.ScreenUpdating = True
End Sub

[HansV]

Here is a macro that will list ALL fonts, including those of the body and heading styles, but it will be slow for large documents.

Code: Select all

Sub FindAllFonts()
    Dim strName As String
    Dim strReturn As String
    Dim oOutputDoc As Document
    Dim oRng As Range
    Dim oChr As Range
    Dim oCol As New Collection
    Dim lngIndex As Long
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range
    On Error Resume Next
    For Each oChr In oRng.Characters
        oCol.Add oChr.Font.Name & " - " & oChr.Font.Size, oChr.Font.Name & " - " & oChr.Font.Size
    Next oChr
    On Error GoTo 0
    For lngIndex = 1 To oCol.Count
        strReturn = strReturn & oCol(lngIndex) & vbCr
    Next lngIndex
    Set oOutputDoc = Documents.Add
    oOutputDoc.Range.Text = strReturn
    Application.ScreenUpdating = True
End Sub

[shreeram.maroo]

That was really helpful, thanks a lot once again..