Sub SpellingListProcess()
' Paul Beverley - Version 27.04.16
' Tidy up a spelling FRedit list from cursor downwards

doTrack = True
lightHighlight = wdGray25
strongHighlight = wdBrightGreen
changeColour = wdColorDarkBlue
minLen = 7

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
      Selection.TypeText Text:="~<"
      Selection.Expand wdParagraph
      Selection.Collapse wdCollapseEnd
      Selection.MoveLeft , 1
      Selection.TypeText Text:=">" & ChrW(124) & "^&"
      If doTrack = 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) > minLen Then
    ' The word is long enough not to bother with whole word only
    ' so leave it as it is, right?
    Else
      If doTrack = True Then
      ' First line is: errorword|^&
        Selection.TypeText Text:=oldWord & ChrW(124) & "^&"
        Selection.Expand wdParagraph
        Selection.Font.StrikeThrough = True
        If oldWord <> newWord Then
          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 = 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|^&
        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
    End If
  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
  End If
  
  Selection.MoveDown , 1
  Selection.Expand wdParagraph
Loop
Selection.Collapse wdCollapseEnd
End Sub