Option Explicit


Sub CheckFormattingOfSelection_FontName_FontSize_ParagraphStyle()

'=========================
'Macro created 2018 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'Before running the macro, select the paragraphs you want to check
'The macro checks font name, font size, and paragraph style of all paragraphs in the selection
'A message shows the resulting values when finished
'If a value is the same for the entire selection, the exact value will be shown
'If a value deviates, '[Mixed values]' will be shown
'NOTE: The result may not be accurate if the selection contains e.g. inline shapes or floating shapes
'The source document remains unchanged
'NOTE: If values deviate, the check will stop as soon as all three values are found to deviate
'=========================

    Dim rngToCheck As Range
    Dim oPara As Paragraph
    Dim lngPara As Long
    Dim lngParasSelected As Long

    Dim strFontName_First As String
    Dim lngFontSize_First As Long
    Dim strStyleParagraph_First As String

    Dim strFontName As String
    Dim lngFontSize As Long
    Dim strStyleParagraph As String

    Dim strMsg As String

    Const strTitle As String = "Check Font Name, Font Size, Paragraph Style of Selection"
    Const strMsgMixed As String = "[Mixed values]"

    On Error GoTo ErrorHandler

    lngParasSelected = Selection.Paragraphs.Count
    
    strMsg = "The selection includes " & lngParasSelected & " paragraph(s)." & vbCr & vbCr & _
        "You can use this command to check whether the same font, font size, and paragraph style have been " & _
        "applied to the entire selection." & vbCr & vbCr & _
        "The Status Bar will show the progress." & vbCr & vbCr & _
        "NOTE: The more paragraphs you have selected, the longer the check may take. " & _
        "If needed, you can stop the check by pressing Ctrl+Break and clicking End in the dialog box that opens."
    
    If MsgBox(strMsg, vbOKCancel, strTitle) <> vbOK Then
        GoTo ExitHere
    End If

    Set rngToCheck = Selection.Range
    'Even if the code does not change the display in Word, it may speed up things
    'turning off Application.ScreenUpdating
    Application.ScreenUpdating = False
    System.Cursor = wdCursorWait
    
    'Initialize values
    lngPara = 0
    
    With rngToCheck
        'Store data for first paragraph - used for comparison during check
        strFontName_First = .Characters.First.Font.Name
        lngFontSize_First = .Characters.First.Font.Size
        strStyleParagraph_First = .Paragraphs.First.Range.ParagraphFormat.Style
    End With
    
    strFontName = strFontName_First
    lngFontSize = lngFontSize_First
    strStyleParagraph = strStyleParagraph_First

    'Show info in the Status Bar
    Application.StatusBar = "Checking formatting of paragraphs. Please wait..."
    
    For Each oPara In rngToCheck.Paragraphs
        With oPara.Range
            lngPara = lngPara + 1
            
            'Show info in Status Bar - update for every 20 paragraphs only
            If lngPara Mod 20 = 0 Then
                Application.StatusBar = "Checking formatting of paragraph " & lngPara & " of " & lngParasSelected & ". Please wait..."
            End If
            
            'The end of row marker in table rows includes a paragraph that is to be ignored
            'Skip in case of an end of cell marker in a table
            If .Tables.Count > 0 Then
                If .Cells.Count = 0 Then
                    'Paragraphs is end of row marker
                    GoTo SkipParagraph
                End If
            End If
            a
            'Check whether font name, font size, paragraph style is the same as is _First
            'If a value deviates from _First, store a value to keep track of this and do not check that type anymore

            'If strFontName has been set to "" then do not check
            If strFontName <> "" Then
                If .Font.Name = strFontName_First Then
                    strFontName = strFontName_First
                Else
                    'Set value to "" and do not check more
                    strFontName = ""
                End If
            End If

            'If lngFontSize has been set to 0 then do not check
            If lngFontSize <> 0 Then
                If .Font.Size = lngFontSize_First Then
                    lngFontSize = lngFontSize_First
                Else
                    lngFontSize = 0
                End If
            End If

            'If strStyleParagraph has been set to "" then do not check
            If strStyleParagraph <> "" Then
                'Style is nothing if mixed
                If .ParagraphFormat.Style Is Nothing Then
                    strStyleParagraph = ""
                Else
                    'If same as strStyleParagraph_First
                    If .ParagraphFormat.Style = strStyleParagraph_First Then
                        strStyleParagraph = strStyleParagraph_First
                    Else
                        strStyleParagraph = ""
                    End If
                End If
            Else
                strStyleParagraph = ""
            End If
        End With

        'Stop all checks if all values now deviate from _First
        If strFontName = "" And lngFontSize = 0 And strStyleParagraph = "" Then
            Exit For
        End If
SkipParagraph:
    Next oPara

    'Even if the selection isn't changed by the code, Word tends to lose it
    'Make sure original selection is selected
    rngToCheck.Select

    Application.ScreenUpdating = True
    System.Cursor = wdCursorNormal
    Application.StatusBar = ""
    
    'Show msg with result
    strMsg = "Finished checking the selected " & lngParasSelected & " paragraph(s)." & vbCr & vbCr

    'Append info about end of row paragraphs if the selection includes table(s)
    With rngToCheck
        'Append info about end of row paragraphs if relevant
        If .Tables.Count > 0 Then
            strMsg = strMsg & "NOTE ABOUT TABLES: The selection includes table row(s). All table rows end with an end of row marker that includes a paragraph mark. " & _
                "Such end of row marker paragraphs are included in the total count of selected paragraphs above but they were ignored during the check." & vbCr & vbCr
        End If

        'Append info about shapes and inline shapes if relevant
        If .ShapeRange.Count > 0 Or .InlineShapes.Count > 0 Then
            strMsg = strMsg & "NOTE ABOUT SHAPES: The selection includes one or more shapes that may contain text. The values below may not be correct, e.g. if text is found inside shapes that are nested inside other shapes." & vbCr & vbCr
        End If
    End With

    'Append further general info
    strMsg = strMsg & "If a value is the same for the entire selection, that specific value is shown. Otherwise, '" & strMsgMixed & "' is shown." & vbCr & vbCr & _
             "The following values apply to the selection:" & vbCr & vbCr

    'Append font name info
    If strFontName = "" Then
        strMsg = strMsg & "Font name:" & vbTab & strMsgMixed & vbCr
    Else
        strMsg = strMsg & "Font name:" & vbTab & strFontName & vbCr
    End If

    'Append font size info
    If lngFontSize = 0 Then
        strMsg = strMsg & "Font size:" & vbTab & strMsgMixed & vbCr
    Else
        strMsg = strMsg & "Font size:" & vbTab & lngFontSize & vbCr
    End If

    'Append style info
    If strStyleParagraph = "" Then
        strMsg = strMsg & "Paragraph style:" & vbTab & strMsgMixed & vbCr
    Else
        strMsg = strMsg & "Paragraph style:" & vbTab & strStyleParagraph & vbCr
    End If

    'Show msg
    MsgBox strMsg, vbOKOnly, strTitle

ExitHere:
    Set rngToCheck = Nothing
    Application.ScreenUpdating = True
    System.Cursor = wdCursorNormal
    Application.StatusBar = ""

    Exit Sub
    '=========================
ErrorHandler:
    MsgBox "An error occurred during the check.", vbOKOnly + vbExclamation, "Error - " & strTitle
    Resume ExitHere
End Sub