CODEWITHSUNDEEP
vbams-word
Oposum
Oposum

Reputation: 1243

MS Word Macro for converting "track changes" markup into text

I am required to subject MS Word documents to a third-party software which does not recognize the "track changes" markup. But I still need to keep the crossed out text and the newly added text so that my colleagues know what was the original version and what is the change.

The following macro works if only one person edited the Word document.

Sub Macro1()

Dim chgAdd As Word.Revision

If ActiveDocument.Revisions.Count = 0 Then
    MsgBox "There are no revisions in this document", vbOKOnly
Else
    ActiveDocument.TrackRevisions = False
    For Each chgAdd In ActiveDocument.Revisions
        If chgAdd.Type = wdRevisionDelete Then
            chgAdd.Range.Font.StrikeThrough = True
            chgAdd.Range.Font.Color = wdColorDarkBlue
            chgAdd.Reject
        ElseIf chgAdd.Type = wdRevisionInsert Then
            chgAdd.Range.Font.Color = wdColorRed
            chgAdd.Accept
        Else
            MsgBox ("Unexpected Change Type Found"), vbOKOnly + vbCritical
            chgAdd.Range.Select ' move insertion point
        End If
    Next chgAdd
End If
End Sub

The problem starts when another person edits the already edited document. In this case, the second author may delete the addition by the first author (not the original text). The above macro, instead of removing it, transforms it into the crossed out text which my colleagues mistakenly think was present in the original.

I would like to only convert deleted original text to crossed out text, but not the deleted edit (edit by one author deleted by another author).

Here is an example of how the macro works (properly) when the text is edited by one author.

Figure 1

In "C" you can see that the dark blue crossed out text is what has been deleted from the original text, and red is what has been added.

Now let's look what happens when the text has been edited by two (or theoretically more) different editors, with the macro run at the end (not inbetween):

Figure 2

The problem becomes evident here in "C": The word "plantes" became dark blue crossed out text even though it was not part of the original text.

As you can see, Figure 2-C differs from Figure 1-C. So I want the updated macro to work so that Figure 2-C is same as Figure 1-C.

Upvotes: 1

Views: 8716

Answers (2)

Rapp
Rapp

Reputation: 11

You can also convert all changes, then search for and delete all text that has both the underline and strike-through attribute.

Upvotes: 1

Cindy Meister
Cindy Meister

Reputation: 25663

The following VBA code loops through a collection of Revisions, checks whether the Revision is an insertion or deletion. If it is and no rejection immediately preceded this part of the loop, then it checks whether the current author was also the author of the previous revision, as there can be no conflict if they're the same.

If they're not the same, then it checks whether the current author is not the main author and whether the current revision is in the same range as the previous, meaning it has "overwritten" a revision by the main author. In this case, the current revision is rejected.

OR, if the author of the previous revision is not the main author and the previous revision is in the same range as the current one, then the previous one has replaced a revision by the main author, then the previous revision is rejected.

On looping, if a revision was just rejected, the code checks whether the new current revision is by an author that is not the main author AND is immediately adjacent to the previous rejection. If that's the case, the new current revision is also rejected.

Then, the code you already have would run after this code has finished.

Sub CompareRevisionsRanges()
  Dim revs As word.Revisions
  Dim rev As word.Revision, revOld As word.Revision
  Dim rngDoc As word.Range
  Dim rngRevNew As word.Range, rngRevOld As word.Range
  Dim authMain As String, authNew As String, authOld As String
  Dim bReject As Boolean

  bReject = False
  Set rngDoc = ActiveDocument.content
  Set revs = rngDoc.Revisions
  If revs.Count > 0 Then
    authMain = revs(1).Author
  Else 'No revisions so...
    Exit Sub
  End If

  For Each rev In revs
    'rev.Range.Select  'for debugging, only
    authNew = rev.Author
    If rev.Type = wdRevisionInsert Or wdRevisionDelete Then
        Set rngRevNew = rev.Range
        'There's only something to compare if an Insertion
        'or Deletion have been made prior to this
        If Not rngRevOld Is Nothing Then
            'The last revision was rejected, so we need to check
            'whether the next revision (insertion for a deletion, for example)
            'is adjacent and reject it, as well
            If bReject Then
                If rngRevNew.Start - rngRevOld.End <= 1 And authNew <> authMain Then
                    rev.Reject
                End If
                bReject = False 'reset in any case
            End If

            'If the authors are the same there's no conflict
            If authNew <> authOld Then
                'If the current revision is not the main author
                'and his revision is in the same range as the previous
                'this means his revision has replaced that
                'of the main author and must be rejected.
                If authNew <> authMain And rngRevNew.InRange(rngRevOld) Then
                    rev.Reject
                    bReject = True
                'If the previous revision is not the main author
                'and the new one is in the same range as the previous
                'this means that revision has replaced this one
                'of the main author and the previous must be rejected.
                ElseIf authOld <> authMain And rngRevOld.InRange(rngRevNew) Then
                    revOld.Reject
                    bReject = True
                End If
            End If
        End If
        Set rngRevOld = rngRevNew
        Set revOld = rev
        authOld = authNew
    End If

  Next        
End Sub

Upvotes: 1

Related Questions