Convert Track Changes to Text in Body AND Header/Footer

[bstephens]

I have the following macro which changes word's track changes to regular text in my preferred format (i.e., delete is strikethrough red, and insertion is double underline blue). Does anyone know how to modify it so that it will also change the track changes in the header/footer to regular text in my preferred format?

The code below only catches the track changes in the main body of the document.


Sub FormatRevisions()
'Converts track changes to regular text formatted with color.

Dim oRange As Range
Dim rev As Revision
Dim txt As String
Dim r As Long
Dim ran As Range
Dim TrackChangesCount As Long

If Documents.Count = 0 Then
Exit Sub
End If

TrackChangesCount = ActiveDocument.Revisions.Count

'If there are no track changes then notify user and exit sub
If TrackChangesCount = 0 Then
MsgBox "There are no track changes in the current document."
Exit Sub
End If

'First switch off TrackChanges, else each of your reformattings will become a revision again
ActiveDocument.TrackRevisions = False
Application.ScreenUpdating = False
'***Now cycle through revisions, identify type of change
For Each rev In ActiveDocument.Revisions
Select Case rev.Type
Case wdRevisionDelete
'secure "deleted" text as well as its position
txt = rev.Range.Text
r = rev.Range.start
'accept the revision to make the markup disappear
rev.Accept
'now type the text formatted as strikethrough at the position of the old text
Set ran = ActiveDocument.Range(r, r)
With ran
.Text = txt
.Font.StrikeThrough = 1
.Font.Color = wdColorRed
'.Font.Bold = 1
End With
Case wdRevisionInsert
Set ran = rev.Range
'accept the revision to make the markup disappear
rev.Accept
'now type the text formatted as underlined at the position of the old text
With ran
.Font.Underline = wdUnderlineDouble
.Font.Color = wdColorBlue
'.Font.Bold = 1
End With
End Select
Next rev

With ActiveDocument
For Each oRange In .StoryRanges
oRange.Revisions.AcceptAll
Next
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox TrackChangesCount & " Track change(s) were converted to regular text."
End Sub
NOTE: This code was slightly adapted from the programmer MakeItSo, seen here:
http://www.tek-tips.com/viewthread.cfm?qid=1485681, thank you MakeItSo.

[gmaxey]

You will need to loop through each storyrange.

Option Explicit
Sub ProcessAllRevisions()
'Convert track changes to regular text formatted with color.
Dim oRngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Word.Shape
Dim lngRevs As Long

If Documents.Count = 0 Then
Exit Sub
End If
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'First switch off TrackChanges, else each of your reformattings will become a revision again
ActiveDocument.TrackRevisions = False
Application.ScreenUpdating = False
'Iterate through all story types in the current document
lngRevs = 0
For Each oRngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
FormatRevisions oRngStory, lngRevs
On Error Resume Next
Select Case oRngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If oRngStory.ShapeRange.Count > 0 Then
For Each oShp In oRngStory.ShapeRange
If oShp.TextFrame.HasText Then
FormatRevisions oShp.TextFrame.TextRange, lngRevs
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Eliminate all other not formatted revisions.
oRngStory.Revisions.AcceptAll
'Get next linked story (if any)
Set oRngStory = oRngStory.NextStoryRange
Loop Until oRngStory Is Nothing
Next
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox lngRevs & " Track change(s) were converted to regular text."
End Sub
Sub FormatRevisions(ByRef oRng As Word.Range, ByRef Count As Long)
Dim oRange As Range
Dim oRev As Revision
Dim oRevRange As Range

Count = Count + oRng.Revisions.Count
'Process revisions in story.
For Each oRev In oRng.Revisions
'Anchor revision range and text.
Set oRevRange = oRev.Range

Select Case oRev.Type
Case wdRevisionDelete
'Kill the revision.
oRev.Accept
'Format revised text.
With oRevRange
.Font.StrikeThrough = 1
.Font.Color = wdColorRed
End With
Case wdRevisionInsert
oRev.Accept
With oRevRange
.Font.Underline = wdUnderlineDouble
.Font.Color = wdColorBlue
End With
End Select
Next oRev
End Sub

[bstephens]

Thanks Greg!

I tried using the code you posted. One thing I noticed was that in the FormatRevisions subroutine, the handling of the Case Statement concerning oRev.Type handles both wdRevisionDelete and wdRevisionInsert the same way, the effect is that "insert" type track changes are replaced with blue text, but because the "delete" type track changes are not stored anywhere, when they are "accepted" they disappear and are not replaced with any text.

I modified it a bit as shown below. I was able to add the concept back that stores the "delete" track changes so they can be reinserted as formatted text, however, I'm still not getting the desired result where changes in the footer are converted to formatted text. Instead, I am simply seeing the track changes in the footer "accepted" and shown as "regular" text (with no formatting).

Let me know if you have any input on how to fix this.

Here is how I added back the concept of storing the "delete" revisions to be reinserted back into the document. My revisions are in the "FormatRevisions" subroutine.

Best,
Brian

Sub ProcessAllRevisions()
'Convert track changes to regular text formatted with color.
'BUG-still trying to make it process changes in the header/footer with formatted text instead of accepting the changes
Dim oRngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Word.Shape
Dim lngRevs As Long

If Documents.Count = 0 Then
Exit Sub
End If
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'First switch off TrackChanges, else each of your reformattings will become a revision again
ActiveDocument.TrackRevisions = False
Application.ScreenUpdating = False
'Iterate through all story types in the current document
lngRevs = 0
For Each oRngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
FormatRevisions oRngStory, lngRevs
On Error Resume Next
Select Case oRngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If oRngStory.ShapeRange.Count > 0 Then
For Each oShp In oRngStory.ShapeRange
If oShp.TextFrame.HasText Then
FormatRevisions oShp.TextFrame.TextRange, lngRevs
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Eliminate all other not formatted revisions.
oRngStory.Revisions.AcceptAll
'Get next linked story (if any)
Set oRngStory = oRngStory.NextStoryRange
Loop Until oRngStory Is Nothing
Next
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox lngRevs & " Track change(s) were converted to regular text."
End Sub
Sub FormatRevisions(ByRef oRng As Word.Range, ByRef Count As Long)
Dim oRange As Range
Dim oRev As Revision
Dim oRevRange As Range
Dim txt As String
Dim r As Long

Count = Count + oRng.Revisions.Count
'Process revisions in story.
For Each oRev In oRng.Revisions

Select Case oRev.Type

Case wdRevisionDelete
'secure "deleted" text as well as its position
txt = oRev.Range.Text 'Here is where I added back the deleted revisions
r = oRev.Range.start
'Kill the revision.
oRev.Accept
'Format revised text.
Set oRevRange = ActiveDocument.Range(r, r)
With oRevRange
.Text = txt 'here is where the deleted revisions are typed back in
.Font.StrikeThrough = 1
.Font.Color = wdColorRed
End With

Case wdRevisionInsert
Set oRevRange = oRev.Range
oRev.Accept
With oRevRange
.Font.Underline = wdUnderlineDouble
.Font.Color = wdColorBlue
End With
End Select

Next oRev
End Sub

[gmaxey]

That was an unintentional oversight :-( Still I don't think you need r or be concerned with .start.


Sub FormatRevisions(ByRef oRng As Word.Range, ByRef Count As Long)
Dim oRange As Range
Dim oRev As Revision
Dim oRevRange As Range
Dim strText As String
Count = Count + oRng.Revisions.Count
'Process revisions in story.
For Each oRev In oRng.Revisions
'Anchor revision range and text.
Set oRevRange = oRev.Range
strText = oRevRange.Text

Select Case oRev.Type
Case wdRevisionDelete
'Kill the revision.
oRev.Accept
'Format revised text.
With oRevRange
.Text = strText
.Font.StrikeThrough = 1
.Font.Color = wdColorRed
End With
Case wdRevisionInsert
oRev.Accept
With oRevRange
.Font.Underline = wdUnderlineDouble
.Font.Color = wdColorBlue
End With
End Select
Next oRev
End Sub

[bstephens]

Greg, Thank you! I am still struggling with getting the revised routine to handle revisions in the footer where the document has multiple non-linked section breaks.

For example: in the following document:
http://dl.dropbox.com/u/1534325/red%20-%20bks1001_2%20vs%20bks1001_1.doc

If you run the macro on the above document, the revisions in the footer of the first section will convert to formatted text as expected, but for any section after the first section the revisions are simply "accepted" and there is not formatted text.

I have been struggling to get the footer with multiple section breaks aspect to work but haven't found the answer.

[gmaxey]

Interesting and disappointingly odd. It seems that passing the linked storyranges (even though they can be selected) doesn't included the revisions they contain.

Try:

Option Explicit
Sub ProcessAllRevisions()
'Convert track changes to regular text formatted with color.
Dim oRngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Word.Shape
Dim lngRevs As Long
Dim i As Long

If Documents.Count = 0 Then
Exit Sub
End If
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'lngJunk = ActiveDocument.Sections(1).Footers(1).Range.StoryType
'First switch off TrackChanges, else each of your reformattings will become a revision again
ActiveDocument.TrackRevisions = False
Application.ScreenUpdating = False
'Iterate through all story types in the current document
lngRevs = 0
For Each oRngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
For i = oRngStory.Revisions.Count To 1 Step -1
lngRevs = lngRevs + 1
FormatRevisions oRngStory.Revisions(i)
Next i
On Error Resume Next
Select Case oRngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If oRngStory.ShapeRange.Count > 0 Then
For Each oShp In oRngStory.ShapeRange
If oShp.TextFrame.HasText Then
For i = oShp.TextFrame.TextRange.Revisions.Count To 1 Step -1
lngRevs = lngRevs + 1
FormatRevisions oShp.TextFrame.TextRange.Revisions(i)
Next i
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set oRngStory = oRngStory.NextStoryRange
Loop Until oRngStory Is Nothing
Next
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox lngRevs & " Track change(s) were converted to regular text."
End Sub
Sub FormatRevisions(ByRef oRev As Revision)
Dim oRevRange As Range
Dim strText As String
'Anchor revision range and text.
Set oRevRange = oRev.Range
strText = oRevRange.Text
On Error Resume Next
Select Case oRev.Type
Case wdRevisionDelete
oRev.Accept
'Format revised text.
With oRevRange
.Text = strText
.Font.StrikeThrough = 1
.Font.Color = wdColorRed
End With
Case wdRevisionInsert
oRev.Accept
With oRevRange
.Font.Underline = wdUnderlineDouble
.Font.Color = wdColorBlue
End With
Case Else
oRev.Accept
End Select
On Error GoTo 0
End Sub

[bstephens]

Greg, it works! I have been trying to figure this out for weeks. Thank you so much! This is very helpful!

[gmaxey]

Glad I could help.