如何保留Word Track Changes格式并按指定要求导出修订内容？

问题概述 #

有一份开启Track Changes功能的Word文档，修订内容以红色或删除线显示。出版社要求导出的修订内容格式为：

"the rain in France" >> should be "the rain in Spain"

原VBA宏存在两个核心问题：

• 导出的修订内容未保留颜色、删除线等格式
• 生成的前后对比内容混乱（例如出现The rain in FranceSpain这类错误）
  尝试过制作接受/拒绝所有修订的副本后用Word对比功能，但该功能依赖颜色区分，不符合要求。

原VBA的问题根源 #

1. 直接修改原文档：循环中调用rev.Accept会修改原文档内容，导致后续修订的上下文错乱，出现文本拼接错误。
2. 丢失格式信息：使用.Text属性获取内容仅能得到纯文本，无法保留修订的格式（删除线、颜色等）。
3. 未处理修订类型差异：插入、删除、格式修改等不同修订类型的前后文本逻辑未区分，导致对比逻辑错误。

修正后的VBA代码 #

Sub ExportTrackedChangesWithFormat()
    Dim originalDoc As Document
    Dim tempDoc As Document
    Dim resultDoc As Document
    Dim rev As Revision
    Dim changeCount As Long
    Dim originalRange As Range
    Dim revisedRange As Range
    Dim changeType As String
    
    ' 初始化原文档
    Set originalDoc = ActiveDocument
    If originalDoc.Revisions.Count = 0 Then
        MsgBox "文档中没有追踪修订。", vbInformation
        Exit Sub
    End If
    
    ' 创建结果文档
    Set resultDoc = Documents.Add
    resultDoc.Content.InsertAfter "修订内容汇总 - 文档：" & originalDoc.Name & vbCrLf & vbCrLf
    
    ' 创建原文档的临时副本（避免修改原文档）
    originalDoc.Save
    Set tempDoc = Documents.Open(originalDoc.FullName)
    tempDoc.TrackRevisions = False ' 关闭追踪，避免操作时产生新修订
    
    changeCount = 0
    
    ' 遍历临时文档中的所有修订
    For Each rev In tempDoc.Revisions
        changeCount = changeCount + 1
        changeType = GetRevisionType(rev.Type)
        
        ' 在结果文档中写入当前修订的基础信息
        With resultDoc.Content
            .InsertAfter "修订 #" & changeCount & ":" & vbCrLf
            .InsertAfter "页码: " & rev.Range.Information(wdActiveEndPageNumber) & " | 行号: " & rev.Range.Information(wdFirstCharacterLineNumber) & " | 类型: " & changeType & vbCrLf
            .InsertAfter "上下文: "
            ' 复制上下文句子并保留格式
            rev.Range.Sentences(1).Copy
            .PasteAndFormat wdFormatOriginalFormatting
            .InsertAfter vbCrLf
        End With
        
        ' 获取原始文本（拒绝当前修订后的内容）
        rev.Reject
        Set originalRange = rev.Range.Duplicate
        originalRange.Expand wdSentence ' 扩展到整句，确保上下文完整
        
        ' 获取修订后文本（重新接受当前修订后的内容）
        tempDoc.Undo ' 撤销拒绝操作
        rev.Accept
        Set revisedRange = rev.Range.Duplicate
        revisedRange.Expand wdSentence
        
        ' 在结果文档中写入指定格式的前后对比
        With resultDoc.Content
            .InsertAfter Chr(34) ' 双引号
            originalRange.Copy
            .PasteAndFormat wdFormatOriginalFormatting
            .InsertAfter Chr(34) & " >> should be >> " & Chr(34)
            revisedRange.Copy
            .PasteAndFormat wdFormatOriginalFormatting
            .InsertAfter Chr(34) & vbCrLf & String(50, "-") & vbCrLf
        End With
    Next rev
    
    ' 关闭临时文档（不保存修改）
    tempDoc.Close SaveChanges:=wdDoNotSaveChanges
    
    ' 提示完成并激活结果文档
    MsgBox "已导出 " & changeCount & " 条修订内容。", vbInformation
    resultDoc.Activate
End Sub

' 辅助函数：返回修订类型的中文描述
Function GetRevisionType(revType As WdRevisionType) As String
    Select Case revType
        Case wdRevisionInsert: GetRevisionType = "插入文本"
        Case wdRevisionDelete: GetRevisionType = "删除文本"
        Case wdRevisionProperty: GetRevisionType = "属性修改"
        Case wdRevisionParagraphNumber: GetRevisionType = "段落编号修改"
        Case wdRevisionDisplayField: GetRevisionType = "域显示修改"
        Case wdRevisionFormat: GetRevisionType = "格式修改"
        Case Else: GetRevisionType = "其他修改"
    End Select
End Function

代码核心优化点 #

1. 临时文档隔离操作：所有接受/拒绝修订的操作都在原文档的临时副本中进行，完全不修改原文档，避免上下文错乱。
2. 格式保留机制：使用Range.Copy和.PasteAndFormat wdFormatOriginalFormatting替代纯文本获取，确保修订的颜色、删除线等格式被完整保留。
3. 精准前后状态获取：通过「拒绝→获取原始文本→撤销拒绝→接受→获取修订后文本」的流程，准确获取每个修订的完整前后内容。
4. 匹配出版社格式：直接生成"原内容" >> should be "修订后内容"的指定格式，无需二次调整。

内容的提问来源于stack exchange，提问作者Mark Springer