Sub CapitAlyse()
' Paul Beverley - Version 21.06.24
' Analyses capitalised words

ignoreHeadings = True
' ignoreHeadings = False

ignoreWords = ",After,All,Although,Also,An,And,As,At,By,For,From,If,In,It,"
ignoreWords = ignoreWords & "Of,On,Our,The,This,Those,There,These,They,Up,We,"

timeStart = Timer
showTime = True

mySpeed = 50
myScreenOff = True

Set FUT = ActiveDocument
doingSeveralMacros = (InStr(FUT.Name, "zzTestFile") > 0)

If myScreenOff = True Then
  Application.ScreenUpdating = False
  On Error GoTo ReportIt
End If

' Count case after hyphenation
myTot = ActiveDocument.Range.End
Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "([A-Z][a-z]{1,}-[A-Z][a-z]{1,})"
  .Replacement.Text = "^&!"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With
numCaps = ActiveDocument.Range.End - myTot
If numCaps > 0 Then WordBasic.EditUndo

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "([A-Z][a-z]{1,}-[a-z]{1,})"
  .Replacement.Text = "^&!"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With
numNoCaps = ActiveDocument.Range.End - myTot
If numNoCaps > 0 Then WordBasic.EditUndo

Selection.HomeKey Unit:=wdStory
Set rng = ActiveDocument.Content
Documents.Add
Selection.FormattedText = rng.FormattedText
Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ": "
  .Wrap = wdFindContinue
  .Replacement.Text = ". "
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = """"
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "[.]{2,}"
  .Replacement.Text = "."
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "(Figure [0-9]{1,}.[0-9]{1,})"
  .Replacement.Text = "\1. "
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "(Fig. [0-9]{1,}.[0-9]{1,})"
  .Replacement.Text = "\1. "
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "[^32]{1,}^13"
  .Replacement.Text = "^p"
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "^13[0-9.\)^t^32" & ChrW(8211) & "]{1,}([A-Z])"
  .Replacement.Text = "^p\1"
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "^13[a-z][.\)\(^t^32" & ChrW(8211) & "]{1,}([A-Z])"
  .Replacement.Text = "^p\1"
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "^t"
  .Wrap = wdFindContinue
  .Replacement.Text = ". "
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = ""
  .Wrap = wdFindContinue
  .Font.StrikeThrough = True
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
End With
StatusBar = "Preparing the text for searching..."

' Underline headings to potentially ignore them
If ignoreHeadings = True Then
   maxWdsInHeading = 20
   For Each pa In ActiveDocument.Paragraphs
     myText = pa.Range.Text
     wdsCount = pa.Range.Words.Count
     If Len(myText) > 3 And wdsCount < maxWdsInHeading Then
       ch = Mid(myText, Len(myText) - 1, 1)
       If InStr(".:", ch) = 0 Then pa.Range.Font.Underline = True
     End If
     i = i + 1: If i Mod mySpeed = 0 Then DoEvents
   Next pa
End If

For Each se In ActiveDocument.Sentences
  If Len(se) > 4 Then
    If InStr("""'(" & ChrW(8216) & ChrW(8220), _
         Trim(se.Words(1))) = 0 Then
      se.Words(1).Font.Underline = True
    Else
      se.Words(2).Font.Underline = True
    End If
    i = i + 1: If i Mod 500 = 0 Then DoEvents
  End If
Next se


With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "<[A-Z][a-zA-Z]{1,}"
  .Font.Underline = False
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .Execute
End With

myCount = 0
myBars = "________________________________________"
allWords = "," & ignoreWords & ","
myResult = ""
Set tst = ActiveDocument.Content
myTot = tst.End
Do While rng.Find.Found = True
  endNow = rng.End
  If InStr(allWords, rng) = 0 Then
    StatusBar = myBars & myBars & myExtra & _
         "    >>> " & Int((myTot - endNow) / 1000)
    testWd = rng.Text
    allWords = allWords & testWd & ","
    lc = LCase(testWd)
    With tst.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = lc
      .MatchCase = True
      .Replacement.Text = "^&!"
      .MatchWildcards = False
      .MatchWholeWord = True
      .Execute Replace:=wdReplaceAll
    End With
    DoEvents
    numLC = ActiveDocument.Range.End - myTot
    If numLC > 0 Then
      WordBasic.EditUndo
      With tst.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = testWd
        .MatchCase = True
        .Replacement.Text = "^&!"
        .Execute Replace:=wdReplaceAll
      End With
      i = i + 1: If i Mod 20 = 0 Then DoEvents
      numCapAll = ActiveDocument.Range.End - myTot
      If numCapAll > 0 Then WordBasic.EditUndo
      With tst.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = testWd
        .Replacement.Text = "^&!"
        .Font.Underline = True
        .Execute Replace:=wdReplaceAll
      End With
      If i Mod 20 = 0 Then DoEvents
      numCapStart = ActiveDocument.Range.End - myTot
      numCapMid = numCapAll - numCapStart
      myExtra = lc & " . ." & Str(numLC) & "____:____"
      myExtra = myExtra & testWd & " . ." & Str(numCapMid)
      If numCapStart > 0 Then
        WordBasic.EditUndo
        myExtra = myExtra & " (+" & Trim(Str(numCapStart)) & ")"
      End If
      myResult = myResult & myExtra & ":" & vbCr
      myCount = myCount + 1
    End If
    rng.start = endNow
    rng.End = endNow
  End If
  rng.Find.Execute
Loop

Selection.WholeStory
Selection.TypeText myResult
Selection.WholeStory
Selection.Range.Style = ActiveDocument.Styles(wdStyleNormal)
Selection.Font.Reset
Selection.Sort
Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ":"
  .Replacement.Text = vbCr
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "_"
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
Selection.HomeKey Unit:=wdStory
Selection.MoveEndWhile cset:=vbCr, Count:=wdForward
Selection.Delete
Selection.TypeText "Capitalisation" & vbCr & vbCr
ActiveDocument.Paragraphs(1).Style = _
     ActiveDocument.Styles(wdStyleHeading1)
     Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "\(*\)"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .Replacement.Font.Color = wdColorGray50
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With

If numCaps + numNoCaps > 0 Then
  Selection.EndKey Unit:=wdStory
  myText = vbCr & vbCr & "Lowercase after hyphen (Non-linear): " & _
       Trim(Str(numNoCaps)) & vbCr & _
       "Uppercase after hyphen (Non-Linear): " & Trim(Str(numCaps)) _
       & vbCr & vbCr
  Selection.TypeText Text:=myText
  Selection.HomeKey Unit:=wdStory
End If

Application.ScreenUpdating = True
If doingSeveralMacros = False Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
  
  totTime = Timer - timeStart
  If showTime = True Then _
    MsgBox ((Int(10 * totTime / 60) / 10) & _
         "  minutes") & vbCr & vbCr & "Word pairs: " & myCount
Else
  FUT.Activate
End If
Exit Sub

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub