Add start and end word fields for tracked changes - vba

Question

I want to add two word fields at the start and end of each track change of a document.
I am iterating through the word revisions using a for-each loop.
Below is my code :
Private Function TrackChangesOnDeletions(ByRef WordRange As Word.Range)
On Error GoTo ErrorHandler
Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objContentControl As Word.ContentControl
Dim objRange As Word.Range
Dim objField As Word.Field
Dim index As Long
Dim objRangeCopy As Word.Range
Dim objFieldEnd As Word.Field
With WordRange.Document
fTrackRevisions = .TrackRevisions
.TrackRevisions = False
End With
With WordRange
For Each objRevision In .Revisions
On Error Resume Next
With objRevision
Set objRange = .Range
'Make sure there's no break character that may exist at the end of the specified range,
'in order to avoid end field appears at the beginning of the next line.
If Len(.Range.Text) > 0 Then
Select Case Asc(WordRange.Characters.Last)
Case 7, 10, 11, 12, 13, 14
.Range.MoveEnd Unit:=WdUnits.wdCharacter, Count:=-1
End Select
End If
'Create a copy of the passed range.
Set objRangeCopy = .Range.Duplicate
With objRangeCopy
.Collapse wdCollapseEnd
'Ensure we are not at an end-of-row marker.
Do While .Information(wdAtEndOfRowMarker) = True
.MoveEnd Unit:=WdUnits.wdCharacter, Count:=1
.Collapse wdCollapseEnd
Loop
End With
'Create a new field at the specified range.
Set objFieldEnd = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, PreserveFormatting:=False)
'Insert end tag
objFieldEnd.Code.InsertAfter " >"
Set objRangeCopy = .Range.Duplicate
objRangeCopy.Collapse Direction:=wdCollapseStart
objFieldEnd.Update
'Insert the start tag
Set objField = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, Text:="Deletion< ", PreserveFormatting:=False)
objField.Update
objRange.SetRange Start:=objField.Code.Start - 1, End:=objFieldEnd.Code.End + 3
objRange.Font.StrikeThrough = True
objRange.Font.ColorIndex = wdRed
.Reject
End With
Err.Clear
Set objContentControl = Nothing
Next objRevision
End With
ErrorHandler:
WordRange.Document.TrackRevisions = fTrackRevisions
Set objContentControl = Nothing
Set objField = Nothing
Set objRange = Nothing
Set objRevision = Nothing
Select Case Err.Number
Case 0
Case Else
ShowUnexpectedError ErrorSource:="TrackChangesOnDeletions" & vbCr & Err.Source
End Select
End Function
My issue is, once the code executed for the first revision, it gets the first revision as the next revision (at for loops' next) as well, event the revision count remain same. So the start and end fields keep adding to the first revision and it makes word crash.
For the below original text,
I need the output as,
When the field codes are hidden, it should display as :
But my code gives the output as, (I have manually stop the for loop iteration to have this capture, else it will add fields and fields and cause word crash)
Form my further testings, I have identified that, if some text were inserted before the revision within the loop, the next revision will be same as the current revision. So the loop is running nonstop and then crash word.
Could anybody please tell me what I am doing wrong here.
Thank you in advance.

Answer 1

In order to move out from the loop at correct time, I used the below approach.
Any improvements or other answers are appreciated.
Private Function TrackChangesOnDeletions(ByRef WordRange As Word.Range)
On Error GoTo ErrorHandler
Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objRange As Word.Range
Dim objRangeCopy As Word.Range
Dim objFieldStart As Word.Field
Dim objFieldEnd As Word.Field
Dim index As Long
Dim revisionCount As Long
With WordRange.Document
fTrackRevisions = .TrackRevisions
.TrackRevisions = False
End With
revisionCount = WordRange.Revisions.Count
index = 1
If (revisionCount > 0) Then
Set objRevision = WordRange.Revisions(index)
Do While Not objRevision Is Nothing
If AllowTrackChangesForDeletion(objRevision) = True Then
On Error Resume Next
With objRevision
Set objRange = .Range
'Make sure there's no break character that may exist at the end of the specified range,
'in order to avoid end field appears at the beginning of the next line.
If Len(objRange.Text) > 0 Then
Select Case Asc(objRange.Characters.Last)
Case 7, 10, 11, 12, 13, 14
objRange.MoveEnd Unit:=WdUnits.wdCharacter, Count:=-1
End Select
End If
'Create a copy of the passed range.
Set objRangeCopy = objRange.Duplicate
With objRangeCopy
.Collapse wdCollapseEnd
'Ensure we are not at an end-of-row marker.
Do While .Information(wdAtEndOfRowMarker) = True
.MoveEnd Unit:=WdUnits.wdCharacter, Count:=1
.Collapse wdCollapseEnd
Loop
End With
'Create a new field at the specified range.
Set objFieldEnd = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, PreserveFormatting:=False)
'Insert end tag
objFieldEnd.Code.InsertAfter " >"
Set objRangeCopy = objRange.Duplicate
objRangeCopy.Collapse Direction:=wdCollapseStart
objFieldEnd.Update
'Insert the start tag
Set objFieldStart = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, Text:="Deletion< ", PreserveFormatting:=False)
objFieldStart.Update
objRange.SetRange Start:=objFieldStart.Code.Start - 1, End:=objFieldEnd.Code.End + 3
objRange.Font.StrikeThrough = True
objRange.Font.ColorIndex = wdRed
.Reject
End With
Err.Clear
End If
'Move to the next revision (unable to use for loop, because it iterates through the first revision everytime and
'then crash word
index = index + 1
If index > revisionCount Then
Exit Do
End If
Set objRevision = WordRange.Revisions(index)
Loop
End If
ErrorHandler:
WordRange.Document.TrackRevisions = fTrackRevisions
Set objFieldEnd = Nothing
Set objFieldStart = Nothing
Set objRange = Nothing
Set objRangeCopy = Nothing
Set objRevision = Nothing
Select Case Err.Number
Case 0
Case Else
ShowUnexpectedError ErrorSource:="TrackChangesOnDeletions" & vbCr & Err.Source
End Select
End Function