Sub SpellingCorrect()
' Paul Beverley - Version 19.04.25
' Corrects spelling and wrong capitalisation

elistNameContains = "elist"

useEqualAsDelete = True

okChars = "='" & ChrW(8217)

Selection.Collapse wdCollapseEnd
wasStart = Selection.Start

Set rng = Selection.Range.Duplicate
rng.Expand wdWord
If rng.Start > 1 Then
  Do
    rng.MoveStart , -1
    ch = Left(rng, 1)
    DoEvents
  Loop Until UCase(ch) = LCase(ch) And InStr(okChars, ch) = 0
  rng.MoveStart , 1
End If
equalPos = InStr(rng, "=")
If equalPos > 0 And useEqualAsDelete = True Then
  Set rng2 = rng.Duplicate
  rng2.Start = rng.Start + equalPos - 2
  rng2.End = rng.Start + equalPos
  rng2.Delete
  Beep
End If

If LCase(rng) = UCase(rng) Then
  If Len(rng) > 2 Then
  ' it's a number, give up
    Beep
    rng.Select
    Exit Sub
  Else
    rng.Collapse wdCollapseStart
    rng.MoveEnd , -2
    rng.Expand wdWord
  End If
End If

' No non-alpha characters at the end of the word
Do While InStr(ChrW(8217) & "!?.,;' ", Right(rng.Text, 1)) > 0
  rng.MoveEnd , -1
  DoEvents
Loop

' Check capitalisation, e.g. BEverley
If Len(rng) > 2 Then
  initChar = rng.Characters(1)
  scndChar = rng.Characters(2)
  lastChar = rng.Characters.Last
  doBeep = True
  If UCase(initChar) = initChar And UCase(scndChar) = scndChar _
       And UCase(lastChar) <> lastChar Then
    doBeep = False
    rng.Characters(2) = LCase(scndChar)
  End If
End If
If Right(rng, 1) = vbCr Then rng.MoveEnd , -1
myWord = rng

' Check spelling language
' (check only first character, in case of split language)
lang = rng.Characters(1).LanguageID

' Check spelling
spellOK = Application.CheckSpelling(myWord, MainDictionary:=lang)

If Not (spellOK) Then
  For Each myDoc In Documents
    If InStr(LCase(myDoc.Name), elistNameContains) > 0 Then
      If InStr(myDoc.Content, vbCr & myWord & vbCr) > 0 Then
        spellOK = True
        Exit For
      End If
    End If
    DoEvents
  Next myDoc
End If
If Not (spellOK) Then
  Set suggList = Application.GetSpellingSuggestions(myWord, _
       MainDictionary:=lang)
  If suggList.Count > 0 Then
    newWord = suggList.Item(1).Name
    If suggList.Count > 1 And LCase(newWord) = myWord _
         Then newWord = suggList.Item(2).Name
  Else
    newWord = myWord
  End If
  If newWord <> myWord Then
    rng.Text = newWord
  Else
    spellOK = Application.CheckSpelling(myWord, _
         MainDictionary:=lang)
    If spellOK = False Then
      If newWord = myWord Then
        Beep
        myTime = Timer
        Do
        Loop Until Timer > myTime + 1
        Beep
        If langName = "English (United States)" _
             And Application.CheckSpelling(myWord, _
             MainDictionary:="English (United Kingdom)") Then
          MsgBox ("Word's spellchecker is playing sillies!")
          Exit Sub
        Else
          MsgBox ("Word offers no suggestion")
        End If
      End If
    End If
  End If
Else
  If doBeep Then Beep
End If
rng.Start = wasStart - 2
rng.Expand wdWord
apoPos = InStr(rng, "'")
If apoPos > 0 Then rng.Characters(apoPos) = ChrW(8217)
rng.Collapse wdCollapseEnd
rng.Select
End Sub