View Single Post
 
Old 06-12-2012, 08:37 AM
EZRider EZRider is offline Windows 2K Office 2003
Novice
 
Join Date: Jul 2009
Posts: 6
EZRider is on a distinguished road
Smile Solution

Thanks Macropod but Word will, with track changes on, keep a record of both changes.

I did manage to solve the issue I was having. If anyone is interested here is the code:

Code:
Sub StrikethroughDeletions() 
     'Turn off Track Changes
    ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions 
     'Highlight revisions of type deletion
    Number = ActiveDocument.Revisions.Count 
    For x = 1 To Number 
        Set myRev = ActiveDocument.Revisions(x).Range 
        This = ActiveDocument.Revisions(x).Type 
        If This = 2 Then 
            myRev.HighlightColorIndex = wdYellow 
        End If 
    Next x 
     ' For all highlighted text, underline and strikethrough if also inserted
    For Y = 1 To Number 
        Set myRev = ActiveDocument.Revisions(Y).Range 
        That = ActiveDocument.Revisions(Y).Type 
        If That = 1 Then 
            myRev.Select 
            If Selection.Range.HighlightColorIndex = wdYellow Then 
                Selection.Font.Underline = True 
                Selection.Font.StrikeThrough = True 
            End If 
        End If 
    Next Y 
     'This will then find and remove the deleted insertions
    Selection.Find.ClearFormatting 
    With Selection.Find.Font 
        .Underline = wdUnderlineSingle 
        .StrikeThrough = True 
        .DoubleStrikeThrough = False 
    End With 
    With Selection.Find 
        .Text = "" 
        .Replacement.Text = "" 
        .Forward = True 
        .Wrap = wdFindContinue 
        .Format = True 
        .MatchCase = False 
        .MatchWholeWord = False 
        .MatchWildcards = False 
        .MatchSoundsLike = False 
        .MatchAllWordForms = False 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
     
     'This will now delete all highlighting
    Dim rngDoc As Range 
    Set rngDoc = ActiveDocument.Range(Start:=0, End:=0) 
    With rngDoc.Find 
        .ClearFormatting 
        .Highlight = True 
        With .Replacement 
            .ClearFormatting 
            .Highlight = False 
        End With 
        .Execute Replace:=wdReplaceAll, Forward:=True, FindText:="", _ 
        ReplaceWith:="", Format:=True 
    End With 
     
     'Turn on track changes
    ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions 
End Sub
Thanks all
Reply With Quote