Changes applied to a Word revision make two paragraphs into one

Question

I am doing changes to a 'word track changes applied' document using VBA.

The red colored paragraph ending mark is a inserted paragraph ending mark.(Make 'track changes ON' > put cursor at the end pf first paragraph > Press Enter > Insert the new paragraph content > format with a different style)

I need to add a field for the insertions with text "Insertion" + inserted text. (The output document in this process goes through some other processes(not in VBA), so in order to let that other processes "That is an insertion", we are adding that field)

Public Sub main()

Dim objRange As Word.Range

Set objRange = Word.ActiveDocument.Range

TrackInsertions objRange

End Sub

Public Sub TrackInsertions(WordRange As Word.Range)
    Dim objRevision As Word.Revision
    Dim objContentControl As Word.ContentControl
    Dim objRange As Word.Range
    With WordRange
       For Each objRevision In .Revisions
           If AllowTrackChangesForInsertion(objRevision) = True Then
              On Error Resume Next
              With objRevision
                  Set objRange = .Range
                  .Range.Font.Underline = wdUnderlineSingle
                  .Range.Font.ColorIndex = wdRed
                  Set objField = objRange.Fields.Add(Range:=objRange, Type:=wdFieldComments, Text:="Insertion " + objRange.Text, PreserveFormatting:=False)
                  .Accept
              End With
              Err.Clear

          End If
        Next objRevision
    End With

    End Sub

Private Function AllowTrackChangesForInsertion(ByRef Revision As Word.Revision) As Boolean
    With Revision
        Select Case .Type
            Case wdRevisionInsert, wdRevisionMovedFrom, wdRevisionMovedTo, wdRevisionParagraphNumber, wdRevisionStyle
                AllowTrackChangesForInsertion = IsTextChangeExist(.Range)
            Case Else
                AllowTrackChangesForInsertion = False
        End Select
    End With
End Function

Private Function IsTextChangeExist(ByRef Range As Word.Range) As Boolean
'False if the range contain inlineshapes, word fields and tables
    Select Case True
        Case Range.InlineShapes.Count > 0
            IsTextChangeExist = False
        Case Range.Fields.Count > 0
            IsTextChangeExist = False
        Case Range.Tables.Count > 0
            IsTextChangeExist = False
        Case Else
            IsTextChangeExist = True
    End Select
End Function

The issue is, when do the above change, the second paragraph with inserted text (I am not counting the paragraph ending marks as paragraphs here) and the first paragraph has turned into one paragraph. As within this code part, actual paragraph count get reduced, the final output (after run through other application) also contains the reduced paragraphs count, which is the issue.

When we read through the revisions, red colored paragraph ending mark + second paragraph goes as one revision. Even that revision has multiple paragraphs, it goes as one revision. If we have applied seperate paragraph styles to the inserted paragraphs, after run through this code, the revision got one style, the immediate paragraph's style. This all occurs because of that Inserted paragraph ending mark.

I tried moving through the word paragraphs, because what I want is to avoid changing the paragraphs count in the document. (tried bottom to up, up to bottom both )But that didn't solve my issue.

Also I have tried to split the revision into two revisions, when

 If objParagraph.End < objRevision.Range.End Then
     .....
 End If

But I am unable to apply range to a new revision.

Now I want to split the revision into parts if we identified a paragraph ending mark within the content, and apply separate fields to them, if possible. So the paragraph count nor the paragraph styles won't change after adding fields.

Or, Is there a way to accept all paragraph ending marks(only) that are marked as inserted within a word document?

Could anybody please help me to proceed with the code, Please tell me if you got other ideas.

Thank you in advance.

Answer 1

With track changes off, the following code example loops the Revisions and checks whether the first character is a paragraph mark. If it is...

Two Range objects are instantiated, one for the paragraph before the one inserted during track changes, another for the one that's a tracked change. This is necessary because Revision.Range becomes invalid when the code makes changes. The styles for both paragraphs are noted.

Then an additional paragraph is inserted immediately following the first one, which takes both paragraphs out of the Revision. The correct styles are applied to the first paragraph and the track changes paragraph, then the extra, inserted paragraph is removed.

Option Explicit

Sub RemoveParasFromRevisions()
    Dim doc As word.Document
    Dim rev As word.Revision, rng As word.Range, rngRev As word.Range
    Dim sPara As String, sStyleOrig As String, sStyleRev As String

    sPara = vbCr
    Set doc = ActiveDocument
    doc.TrackRevisions = False
    For Each rev In doc.Revisions
        'If the start of the Revision is a paragraph mark
        If InStr(rev.Range.text, sPara) = 1 Then
            'Get ranges for the revision as the original revision
            'will no longer be available after the changes made
            Set rngRev = rev.Range.Duplicate
            Set rng = rngRev.Duplicate

            'Get the styles of the first paragraph and last paragraph
            sStyleRev = rngRev.Paragraphs.Last.style
            sStyleOrig = rng.Paragraphs(1).style

            'Make sure the revision range is beyond the previous paragraph
            rngRev.Collapse wdCollapseEnd
            'Make sure the range for the previous paragraph is outside the revision
            rng.Collapse wdCollapseStart
            'Insert another paragraph as "buffer"
            rng.InsertAfter sPara
            'Ensure the first paragraph has its original style
            rng.Paragraphs(1).Range.style = sStyleOrig
            'And the revision the style applied to the text while track changes was on
            rngRev.style = sStyleRev
            'Delete the "buffer" paragraph
            rng.MoveStart wdCharacter, 1
            rng.Characters.Last.Delete
        End If
    Next

    'Test it
'    Dim counter As Long
'    For Each rev In doc.Revisions
'        counter = counter + 1
'        Debug.Print rev.Range.text, counter
'    Next
'    Debug.Print doc.Revisions.Count
End Sub