Sub SpellAlyse()
' Paul Beverley - Version 25.05.23
' Complete spellchecking system

ignoreNumbers = True

spellingListName = "SpellAlyse"
spellingFreqName = "SpellAlyse frequencies"
ignoreDoc = "zzSwitchList"

myFind = "´a,´e,¨a,¨e,¨o,¨u,ˆo"
myReplace = "á,é,ä,ë,ö,ü,ô"

CR = vbCr
CR2 = CR & CR
sp1 = " "
sp2 = sp1 & sp1

myScreenOff = True

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

Dim lossLen As Long
Dim newLen As Long

numParas = FUT.Paragraphs.count
numWords = FUT.Content.ComputeStatistics(wdStatisticWords)
myProfile = numWords / numParas

If myProfile < 1.1 Then GoTo autoCorrect

' List all possible spelling errors
Set rng = ActiveDocument.Content
rng.End = 2
thisLanguage = rng.LanguageID
langText = Languages(rng.LanguageID).NameLocal

langPrompt = "Spellcheck with " & langText & " dictionary. OK?"
If doingSeveralMacros = False Then
  myResponse = MsgBox(langPrompt, vbQuestion + vbYesNoCancel, _
       "SpellAlyse")
  If myResponse <> vbYes Then Exit Sub
End If

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

allExcepts = CR
'Collect all words from all word lists
For Each myDoc In Documents
Debug.Print myDoc.Name
  pNum = myDoc.Paragraphs.count
  myNum = 3
  If pNum < 3 Then myNum = pNum
  Set rng = myDoc.Paragraphs(myNum).Range
  rng.Start = 0
  If InStr(LCase(rng.Text), "elist") > 0 Then
    For Each myPar In myDoc.Paragraphs
      myWord = Trim(myPar.Range.Words(1).Text)
      If Len(myWord) > 2 Then
        allExcepts = allExcepts & myWord & CR
        Debug.Print allExcepts
      End If
      DoEvents
    Next myPar
  End If
  DoEvents
Next myDoc
Debug.Print allExcepts

' Create a text-only copy in another file
Set rngOld = FUT.Content
Documents.Add
Set erList = ActiveDocument
Set rng = ActiveDocument.Content
rng.LanguageID = thisLanguage
rng.FormattedText = rngOld.FormattedText

numNotes = FUT.Endnotes.count
If numNotes > 0 Then
  rng.Collapse wdCollapseEnd
  rng.FormattedText = FUT.StoryRanges(wdEndnotesStory).FormattedText
End If

numNotes = FUT.Footnotes.count
If numNotes > 0 Then
  rng.Collapse wdCollapseEnd
  rng.FormattedText = FUT.StoryRanges(wdFootnotesStory).FormattedText
End If

' copy all the textboxes to the end of the text
shCount = FUT.Shapes.count
If shCount > 0 Then
  Selection.EndKey Unit:=wdStory
  For j = 1 To shCount
    Set shp = FUT.Shapes(j)
    If shp.Type <> 24 And shp.Type <> 3 Then
      If shp.TextFrame.HasText Then
        Set rng = shp.TextFrame.TextRange
        If Len(rng.Text) > 1 Then
          Selection.Text = rng.Text
          Selection.EndKey Unit:=wdStory
        End If
      End If
    End If
    DoEvents
  Next
End If

' Add a newline for safety
Selection.TypeText CR

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Font.StrikeThrough = True
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^2"
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  
  .Text = "([!a-zA-Z])['" & ChrW(8216) & "]"
  .Replacement.Text = "\1"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With

' Change ligature characters into character pairs
myFind = myFind & "," & ChrW(-1280) & "," & ChrW(-1279) & _
     "," & ChrW(-1278) & "," & ChrW(-1277) & "," & ChrW(-1276) _
     & "," & ChrW(185) & "," & ChrW(178) & "," & ChrW(179)
myReplace = myReplace & ",ff,fi,fl,ffi,ffl, , , , , "
fnd = Split(myFind, ",")
rpl = Split(myReplace, ",")

For i = 0 To UBound(fnd)
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = fnd(i)
    .Wrap = wdFindContinue
    .Replacement.Text = rpl(i)
    .MatchCase = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  End With
  DoEvents
Next i

Selection.HomeKey Unit:=wdStory
Selection.TypeText Text:="Preparing file for spellchecking" & CR2
ActiveDocument.Paragraphs(1).Style = _
     ActiveDocument.Styles(wdStyleHeading1)
DoEvents
Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
   If ignoreNumbers = True Then
     .Text = "[!a-zA-Z^13'" & ChrW(8217) _
     & ChrW(248) & "-" & ChrW(591) _
     & ChrW(697) & "-" & ChrW(703) _
     & ChrW(&H591) & "-" & ChrW(&H5FF) _
     & ChrW(7680) & "-" & ChrW(7935) & "]"
   Else
     .Text = "[!a-zA-Z0-9^13'" & ChrW(8217) _
     & ChrW(248) & "-" & ChrW(591) _
     & ChrW(697) & "-" & ChrW(703) _
     & ChrW(&H591) & "-" & ChrW(&H5FF) _
     & ChrW(7680) & "-" & ChrW(7935) & "]"
   End If
  .Replacement.Text = sp1
  .Wrap = wdFindContinue
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
       
  .Text = "([a-zA-Z])['" & ChrW(8217) & "][!a-zA-Z]"
  .Replacement.Text = "\1 "
  .Execute Replace:=wdReplaceAll
  DoEvents

  .Text = "^p"
  .Replacement.Text = sp1
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .Text = "^t"
  .Execute Replace:=wdReplaceAll
  DoEvents

  .Text = "^p"
  .Execute Replace:=wdReplaceAll
  DoEvents
End With

' Create spelling error list
Set rng = ActiveDocument.Content

txt = rng.Text
' Ensure a single space between words
Do
  nowLen = Len(txt)
  txt = Replace(txt, sp2, sp1)
  DoEvents
Loop Until Len(txt) = nowLen

erList1 = ""
erListFreq1 = ""
erList2 = ""
erListFreq2 = ""

If Left(txt, 1) <> sp1 Then txt = sp1 & txt
Do
  spPos = InStr(Mid(txt, 2), " ")
  wd = Trim(Left(txt, spPos))
  spOK = Application.CheckSpelling(wd, MainDictionary:=langText)
  spEX = InStr(allExcepts, CR & wd & CR)
  nowLen = Len(txt)
  txt = Replace(txt, sp1 & wd & sp1, sp1)
  txt = Replace(txt, sp1 & wd & sp1, sp1)
  lossLen = Len(txt)
  If spOK = False And spEX = False And Len(wd) > 2 Then
  ' record it as a spelling error
    numErrs = Int((nowLen - lossLen) / Len(wd))
    numText = " . . . " & Trim(Str(numErrs))
    If LCase(wd) = wd Then
      erList2 = erList2 & wd & CR
      erListFreq2 = erListFreq2 & wd & numText & CR
    Else
      erList1 = erList1 & wd & CR
      erListFreq1 = erListFreq1 & wd & numText & CR
    End If
    StatusBar = wd & numText
    Debug.Print wd & numText
  End If
  DoEvents
Loop Until Len(txt) < 5

Selection.WholeStory
Selection.Delete
Selection.TypeText Replace(erList2, CR2, CR)
Selection.WholeStory
Selection.Sort SortOrder:=wdSortOrderAscending, _
     SortFieldType:=wdSortFieldAlphanumeric

Selection.EndKey Unit:=wdStory
Selection.TypeText CR
listStart = Selection.Start
Selection.TypeText CR & Replace(erList1, CR2, CR)
Selection.Start = listStart
Selection.Sort SortOrder:=wdSortOrderAscending, _
     SortFieldType:=wdSortFieldAlphanumeric

Selection.WholeStory
Selection.LanguageID = thisLanguage
Selection.Style = wdStyleNormal
Selection.Collapse wdCollapseStart
Selection.TypeText spellingListName & vbCr
ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles(wdStyleHeading1)

Documents.Add
Selection.TypeText Replace(erListFreq2, CR2, CR)
Selection.WholeStory
DoEvents
Selection.Sort SortOrder:=wdSortOrderAscending, _
     SortFieldType:=wdSortFieldAlphanumeric
DoEvents
Selection.EndKey Unit:=wdStory
Selection.TypeText CR
listStart = Selection.Start
Selection.TypeText CR & Replace(erListFreq1, CR2, CR)
Selection.Start = listStart
DoEvents
Selection.Sort SortOrder:=wdSortOrderAscending, _
     SortFieldType:=wdSortFieldAlphanumeric
DoEvents

Selection.WholeStory
Selection.LanguageID = thisLanguage
Selection.Style = wdStyleNormal
Selection.HomeKey Unit:=wdStory
Selection.TypeText spellingFreqName & vbCr
ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles(wdStyleHeading1)
Selection.Collapse wdCollapseStart

erList.Activate
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
StatusBar = ""
If doingSeveralMacros = False Then
  totTime = Int(10 * (Timer - timeStart) / 60) / 10
  If totTime > 2 Then myResponse = MsgBox((totTime & "  minutes"), _
  vbOKOnly, "SpellAlyse")
  Beep
Else
  FUT.Activate
End If
Exit Sub

autoCorrect:
Application.ScreenUpdating = True
allText = FUT.Content.Text
If InStr(allText, "|") > 0 Then GoTo createListPair

myResponse = MsgBox("Auto-create FRedit list items?", _
     vbQuestion + vbYesNoCancel, "SpellAlyse")
If myResponse <> vbYes Then Exit Sub
Beep
myResponse = MsgBox("Turn track changes on?", _
     vbQuestion + vbYesNoCancel, "SpellAlyse")
If myResponse = vbCancel Then Exit Sub
myRev = (myResponse = vbYes)
If myRev Then ActiveDocument.TrackRevisions = True

' Add auto-created FRedit items
Set rng = ActiveDocument.Content

' (only first character, in case of split language)
rng.End = rng.Start + 1
langName = Languages(rng.LanguageID).NameLocal

i = 0
Do
  i = i + 1
  Set myPara = FUT.Paragraphs(i)
  wd = Replace(myPara.Range.Text, CR, "")
  If LCase(wd) = wd And wd <> "" Then
    DoEvents
    spellOK = Application.CheckSpelling(wd, _
         MainDictionary:=langName)
    Set suggList = Application.GetSpellingSuggestions(wd, _
         MainDictionary:=langName)
    newWord = ""
    DoEvents
    If suggList.count > 0 And Not (spellOK) Then
      newWord = suggList.Item(1).Name
      If myRev = True Then
        Set rng = myPara.Range.Duplicate
        rng.MoveEnd , -1
        myFR = "~<" & wd & ">|" & newWord
        rng.Text = myFR
      Else
        myPara.Range.Text = "~<" & wd & ">|" & newWord & CR
      End If
      myPara.Range.Select
      Selection.Collapse wdCollapseEnd
      DoEvents
    End If
  End If
  DoEvents
Loop Until i > 3 And myPara = CR
ActiveDocument.TrackRevisions = False
Exit Sub

createListPair:
' Make Flist + MarkIt list + Elist
Application.ScreenUpdating = True
myResponse = MsgBox("Create exceptions and FRedit lists?", _
     vbQuestion + vbYesNoCancel, "SpellAlyse")
If myResponse <> vbYes Then Exit Sub

Documents.Add
Set eList = ActiveDocument
Selection.TypeText Text:="| Elist" & CR2
eList.Paragraphs(1).Style = eList.Styles(wdStyleHeading1)
Set eRng = ActiveDocument.Content

Documents.Add
Set fList = ActiveDocument
Selection.TypeText Text:="| FRedit" & CR2
fList.Paragraphs(1).Style = fList.Styles(wdStyleHeading1)
Set fRng = ActiveDocument.Content

' FUT is now the spelling error list
For i = 1 To FUT.Paragraphs.count
  DoEvents
  Set itemRng = FUT.Paragraphs(i).Range
  If InStr(itemRng.Text, spellingListName) = 0 _
       And Len(itemRng.Text) > 3 Then
    DoEvents
    If InStr(itemRng.Text, "|") > 0 Then
      fRng.Collapse wdCollapseEnd
      fRng.FormattedText = itemRng.FormattedText
    Else
      myFontCol = itemRng.Font.Color
      myHiCol = itemRng.HighlightColorIndex
      If myFontCol > 0 Or myHiCol > 0 Then
        fRng.Collapse wdCollapseEnd
        fRng.Text = "~<" & Replace(itemRng.Text, CR, _
             "") & ">" & "|^&" & CR
        fRng.Expand wdParagraph
        fRng.Font.StrikeThrough = True
        If myFontCol > 0 Then fRng.Font.Color = myFontCol
        If myHiCol > 0 Then fRng.HighlightColorIndex = myHiCol
        fRng.Collapse wdCollapseEnd
      Else
        eRng.Collapse wdCollapseEnd
        eRng.Text = itemRng.Text
      End If
    End If
  End If
  DoEvents
Next i
Exit Sub

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