用于将“跟踪更改”标记转换为文本的 MS Word 宏

Question

我需要将 MS Word 文档提交给无法识别“跟踪更改”标记的第三方软件。但是我仍然需要保留划掉的文本和新添加的文本，以便我的同事们知道原来的版本是什么，有什么变化。

如果只有一个人编辑 Word 文档，则以下宏有效。

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

当另一个人编辑已编辑的文档时，问题就开始了。在这种情况下，第二作者可以删除第一作者（不是原文）的添加。上面的宏没有将其删除，而是将其转换为我的同事错误地认为原始文本中存在的划掉的文本。

我只想将已删除的原始文本转换为划掉的文本，而不是已删除的编辑（一位作者的编辑被另一位作者删除）。

这是一个示例，说明当文本由一位作者编辑时宏如何（正确）工作。

在“C”中可以看到，深蓝色划掉的文字是从原文中删除的，红色是添加的。

现在让我们看看当文本被两个（或理论上更多）不同的编辑器编辑时会发生什么，宏运行在最后（不是中间）：

问题在“C”中变得很明显：“plantes”这个词变成了深蓝色划掉的文本，即使它不是原始文本的一部分。

如您所见，图 2-C 与图 1-C 不同。所以我希望更新后的宏能够正常工作，使图 2-C 与图 1-C 相同。

Answer 1

以下 VBA 代码循环遍历一组修订，检查修订是插入还是删除。如果是，并且在这部分循环之前没有立即拒绝，那么它会检查当前作者是否也是先前修订的作者，因为如果它们相同，则不会发生冲突。

如果它们不相同，则检查当前作者是否不是主要作者，以及当前修订版是否与之前的修订版在同一范围内，这意味着它已经“覆盖”了主要作者的修订版。在这种情况下，当前版本被拒绝。

或者，如果上一个修订的作者不是主要作者，并且之前的修订与当前的修订在同一范围内，那么之前的修订已经由主要作者替换了一个修订，那么之前的修订被拒绝.

在循环中，如果一个修订版刚刚被拒绝，代码会检查新的当前修订版是否由非主要作者的作者撰写，并且与之前的拒绝直接相邻。如果是这种情况，新的当前版本也会被拒绝。

然后，您已经拥有的代码将在此代码完成后运行。

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

Answer 2

您还可以转换所有更改，然后搜索并删除所有同时具有下划线和删除线属性的文本。