Sub SpellingSuggest()
' Paul Beverley - Version 12.02.24
' Checks/corrects spellings or adds/subtracts FRedit suggested change

If LCase(Selection) = UCase(Selection) Then Selection.MoveLeft , 1
Set rngWd = Selection.Range.Duplicate
rngWd.Expand wdWord
Do While InStr(ChrW(8217) & "' ", Right(rngWd.Text, 1)) > 0
  rngWd.MoveEnd , -1
  DoEvents
Loop
a = rngWd.Characters(1)
b = rngWd.Characters(2)
If UCase(a) = a And UCase(b) = b Then _
     rngWd.Characters(2) = LCase(b)
myWord = rngWd
newWord = myWord

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

rng.End = ActiveDocument.Content.End
rng.Start = ActiveDocument.Content.End - 2
langName1 = Languages(rng.LanguageID).NameLocal
langName2 = Languages(Selection.LanguageID).NameLocal
StatusBar = langName & "    " & langName1 & "    " & langName2

Set rng = Selection.Range.Duplicate
rng.Expand wdParagraph
wdsInPara = rng.Words.Count
myPara = rng
initChar = Left(myWord, 1)
lastChar = Right(myWord, 1)

spellOK = Application.CheckSpelling(myWord, MainDictionary:=langName)
Set suggList = Application.GetSpellingSuggestions(myWord, _
     MainDictionary:=langName)
If suggList.Count > 0 And Not (spellOK) Then _
     newWord = suggList.Item(1).Name

' If initial letter is a capital keep the capital
If LCase(initChar) <> initChar Then _
     newWord = UCase(Left(newWord, 1)) & Mid(newWord, 2)
  
' If final letter is a capital, make it all caps
If LCase(lastChar) <> lastChar Then _
     newWord = UCase(newWord)

' If it's the only word in the para (a FRedit list)
If wdsInPara < 3 And ActiveDocument.Words.Count > 10 Then
  oldWord = myWord
  Selection.Expand wdWord
  Selection.Collapse wdCollapseEnd
  If Asc(Selection) = 32 Then
    Selection.MoveEnd , 1
    oldWord = oldWord & "^32"
    newWord = newWord & "^32"
  End If
  Selection.Expand wdParagraph
  Selection.TypeText ChrW(172) & oldWord & "|" & newWord & CR
  Selection.MoveRight , 1
  If newWord = myWord Then Beep
Else
  If newWord <> myWord Then
    Beep
    myTime = Timer
    Do
    Loop Until Timer > myTime + 0.2
    Beep
    rngWd.Text = newWord
    rngWd.Select
    Selection.Collapse wdCollapseEnd
  Else
    spellOK = Application.CheckSpelling(myWord, _
         MainDictionary:=langName)
    If spellOK Then
      Selection.Collapse wdCollapseEnd
      Beep
    Else
      If newWord = myWord Then
        Beep
        myTime = Timer
        Do
        Loop Until Timer > myTime + 0.2
        Beep
        Do
        Loop Until Timer > myTime + 0.4
        Beep
        If langName = "English (United States)" _
             And Application.CheckSpelling(myWord, _
             MainDictionary:="English (United Kingdom)") Then
          MsgBox ("Word's spellcheck is playing sillies!")
          Exit Sub
        Else
          MsgBox ("Word offers no suggestion")
        End If
      End If
    End If
  End If
End If
End Sub