Sub RevsToUnderlineStrikethrough()
'
' Converts tracked revisions in selected text into underline/strikethrough format,
' and removes tracked revisions from the selected text.
'
Dim chgRev As Word.Revision 'Declaring variable
If Selection.Range.Revisions.Count = 0 Then 'Nothing to do, show error dialog
    MsgBox "Nothing selected or no revisions in selection.", vbOKOnly
Else
    ActiveDocument.TrackRevisions = False 'Disable tracked revisions
    For Each chgRev In Selection.Range.Revisions 'Main function
        If chgRev.Type = wdRevisionDelete Then 'Strikethrough deletion and reject change
            If chgRev.Range.Characters.Count <= 5 Then 'Delete with brackets
                Dim rngRev As Range
                Set rngRev = chgRev.Range
                chgRev.Range.Font.StrikeThrough = False
                chgRev.Reject
                rngRev.InsertBefore ("[[")
                rngRev.InsertAfter ("]]")
            Else
                chgRev.Range.Font.StrikeThrough = True
                chgRev.Reject
            End If
        ElseIf chgRev.Type = wdRevisionInsert Then 'Underline addition and accept change
            chgRev.Range.Font.Underline = wdUnderlineSingle
            chgRev.Accept
        End If
    Next chgRev
    For Each strChar In Selection.Range.Characters 'insert spaces between striken and added text
        Set strNextChar = strChar.Next(wdCharacter, 1)
        If strChar.Text <> Chr(32) And Not (strNextChar Is Nothing) Then
            If strChar.Font.StrikeThrough = True And strNextChar.Font.Underline = wdUnderlineSingle Then
                strChar.InsertAfter (" ")
            ElseIf strChar.Font.Underline = wdUnderlineSingle And strNextChar.Font.StrikeThrough = True Then
                strChar.InsertAfter (" ")
            End If
        End If
    Next strChar
    Set strPrevChar = Nothing
    Set strNextChar = Nothing
    For Each strChar In Selection.Range.Characters 'Get rid of stray underlined and stricken-through spaces
        Set strPrevChar = strChar.Previous(wdCharacter, 1)
        Set strNextChar = strChar.Next(wdCharacter, 1)
        If strChar.Text = Chr(32) Then
            If strChar.Font.StrikeThrough = True Then 'Stricken-through space
                If strPrevChar.Font.StrikeThrough = False Then 'De-strikethrough leading stricken space
                    strChar.Font.StrikeThrough = False
                End If
                If strNextChar.Font.StrikeThrough = False Then 'De-strikethrough trailing stricken space
                    strChar.Font.StrikeThrough = False
                End If
            End If
            If strChar.Font.Underline = wdUnderlineSingle Then 'Underlined space
                If strPrevChar.Font.Underline = wdUnderlineNone Then 'De-underline leading underline spaces
                    strChar.Font.Underline = wdUnderlineNone
                End If
                If strNextChar.Font.Underline = wdUnderlineNone Then 'De-underline trailing underline spaces
                    strChar.Font.Underline = wdUnderlineNone
                End If
            End If
        End If
    Next strChar
    Set strPrevChar = Nothing
    Set strNextChar = Nothing
    
    With Selection.Range.Find 'Add/delete spaces around double brackets - this doesn't work perfectly yet either
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        .Text = "([! ])\[\["
        .Replacement.Text = "\1 [["
        .Execute Replace:=wdReplaceAll
        .Text = "\]\]([0-9A-z])"
        .Replacement.Text = "]] \1"
        .Execute Replace:=wdReplaceAll
        .Text = "\[\[([ ]@)"
        .Replacement.Text = "[["
        .Execute Replace:=wdReplaceAll
        .Text = "([ ]@)\]\]"
        .Replacement.Text = "]]"
        .Execute Replace:=wdReplaceAll
        ' Delete empty double bracket sets
        .Text = "\[\[\]\]"
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
        .MatchWildcards = False
        .Text = " [["
        .Font.Underline = wdUnderlineSingle
        .Replacement.Text = " [["
        .Replacement.Font.Underline = wdUnderlineNone
        .Execute Replace:=wdReplaceAll
        ' Delete duplicate spaces, unless after closing paren--can't get this to work, so using loop below
        ' .Text = "([! \)])([ ]@)"
        ' .Replacement.Text = "\1 "
        ' .Execute Replace:=wdReplaceAll
    End With
    
    
    For Each strChar In Selection.Range.Characters ' Delete duplicate spaces, unless after closing paren
        ' If rng.Start = 0 Then
        ' ElseIf rng.End = ActiveDocument.Range.End Then
        Set strPrevChar = strChar.Previous(wdCharacter, 1)
        Set strNextChar = strChar.Next(wdCharacter, 1)
        If strPrevChar Is Nothing Then
            If strChar.Text = Chr(32) Then ' The selection is the first character in the document
                If strNextChar Is Nothing Then ' The last character is a space; delete it
                    strChar.Delete
                End If
                Do While strNextChar.Text = Chr(32) 'Delete any one or more spaces after this space
                    strNextChar.Delete
                    Set strNextChar = strChar.Next(wdCharacter, 1)
                Loop
            End If
        ElseIf strChar.Text = Chr(32) And strPrevChar <> ")" Then
            If strNextChar Is Nothing Then 'The last character is a space; delete it
                strChar.Delete
            End If
            Do While strNextChar.Text = Chr(32) 'Delete any one or more spaces after this space
                strNextChar.Delete
                Set strNextChar = strChar.Next(wdCharacter, 1)
            Loop
        End If
    Next strChar
    'Set strPrevChar = Nothing
    'Set strNextChar = Nothing

End If
End Sub