Sub FReditListProcess()
' Paul Beverley - Version 08.02.22
' Tidies up a spelling FRedit list from cursor downwards

makeCopyingNotTracked = True
' lightHighlight = wdGray25
lightHighlight = wdNoHighlight

' lightColour = wdColorBlack
lightColour = wdColorDarkBlue

strongHighlight = wdBrightGreen
changeColour = wdColorDarkBlue
minLength = 7

Application.ScreenUpdating = True
On Error GoTo ReportIt

myResponse = MsgBox("Any case? (Yes)" & vbCr & vbCr & "or Case Sensitive? (No)", _
      vbQuestion + vbYesNoCancel, "FRedit List Process")
If myResponse = vbCancel Then Exit Sub
doAnyCase = (myResponse = vbYes)

Selection.Expand wdParagraph
Do While Len(Selection) > 1
  Selection.Expand wdParagraph
  Selection.End = Selection.Start + 1
  nowHighlight = Selection.Range.HighlightColorIndex
  nowColour = Selection.Range.Font.Color
  Selection.Expand wdParagraph
  Selection.MoveEnd , -1
  padPos = InStr(Selection, ChrW(124))
  If padPos = 0 Then
    ' Check if text colour is not black
    doCopy = (nowColour <> wdBlack And nowColour <> wdColorAutomatic)
    ' Check if it is highlighted
    If Selection.Range.HighlightColorIndex > 0 Then doCopy = True
    ' Check if italic, bold or underline
    If Selection.Font.Italic Then doCopy = True
    If Selection.Font.Bold Then doCopy = True
    If Selection.Font.Underline Then doCopy = True
    
    ' If it has one of these then FRedit must copy it
    If doCopy = True Then
      Selection.Collapse wdCollapseStart
      If doAnyCase = True Then
        Selection.TypeText Text:=ChrW(172)
        Selection.Expand wdParagraph
        Selection.Collapse wdCollapseEnd
        Selection.MoveLeft , 1
        Selection.TypeText Text:=ChrW(124) & "^&"
      Else
        Selection.TypeText Text:="~<"
        Selection.Expand wdParagraph
        Selection.Collapse wdCollapseEnd
        Selection.MoveLeft , 1
        Selection.TypeText Text:=">" & ChrW(124) & "^&"
      End If
      If makeCopyingNotTracked = True Then
        Selection.Expand wdParagraph
        Selection.Font.StrikeThrough = True
      End If
    End If
  Else
    oldWord = Left(Selection, padPos - 1)
    newWord = Mid(Selection, padPos + 1)
    If Len(oldWord) > minLength Then
    ' The word is long enough not to bother with whole word only
    ' so leave it as it is, but just add bent pipe if case insensitive
      If doAnyCase = True Then
        Selection.Collapse wdCollapseStart
        Selection.TypeText Text:=ChrW(172)
        Selection.Expand wdParagraph
        Selection.Collapse wdCollapseStart
      End If
    Else
      If makeCopyingNotTracked = True Then
      ' First line is: errorword|^&
        If doAnyCase = True Then Selection.TypeText Text:=ChrW(172)
        Selection.TypeText Text:=oldWord & ChrW(124) & "^&"
        Selection.Expand wdParagraph
        Selection.Font.StrikeThrough = True
        If oldWord <> newWord Then
          Selection.Range.HighlightColorIndex = lightHighlight
          Selection.Range.Font.Color = lightColour
      ' Next line is: ~<errorword>|correctword
          Selection.Collapse wdCollapseEnd
          Selection.TypeText Text:="~<" & oldWord & ">" & _
               ChrW(124) & newWord & vbCr
          Selection.MoveLeft , 2
          Selection.Expand wdParagraph
          Selection.Range.HighlightColorIndex = nowHighlight
          Selection.Range.Font.Color = nowColour
        Else
          Selection.Range.HighlightColorIndex = nowHighlight
        End If
        Selection.Collapse wdCollapseStart
      Else
      ' We're not tracking
      ' First line is: errorword|^&
        If doAnyCase = True Then Selection.TypeText Text:=ChrW(172)
        Selection.TypeText Text:=oldWord & ChrW(124) & "^&"
        Selection.Expand wdParagraph
        Selection.Range.HighlightColorIndex = lightHighlight
      ' Next line is: ~<errorword>|correctword
        Selection.Collapse wdCollapseEnd
        Selection.TypeText Text:="~<" & oldWord & ">" & ChrW(124) _
             & newWord & vbCr
        Selection.MoveLeft , 2
        Selection.Expand wdParagraph
        Selection.Range.HighlightColorIndex = strongHighlight
        Selection.Range.Font.Color = changeColour
'        Selection.range.Font.Color = nowColour
      End If
      DoEvents
    End If
    DoEvents
  End If
  
  ' Now check if it has still got no vertical bar
  Selection.Expand wdParagraph
  If InStr(Selection, ChrW(124)) = 0 Then
    Selection.Delete
    Selection.MoveLeft , 1
  Else
  DoEvents
  End If
  Selection.MoveDown , 1
  Selection.Expand wdParagraph
  DoEvents
Loop
Selection.Collapse wdCollapseEnd
Selection.MoveLeft , -1
Selection.MoveLeft , 1
Beep
End Sub