应用于 Word 修订的更改使两个段落合二为一

Question

我正在使用 VBA 对“应用的单词跟踪更改”文档进行更改。

红色的段落结尾标记是一个插入段落结尾标记。（使'track changes ON'>将光标放在第一段的末尾>按Enter>插入新的段落内容>格式风格不同）

我需要为插入添加一个字段，其中包含文本“插入”+ 插入文本。 （此过程中的输出文档会经过一些其他过程（不是在 VBA 中），所以为了让 其他进程“这是一个插入”，我们正在添加该字段）

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

问题是，何时进行上述更改，插入文本的第二段 （我这里没有把段落结束标记算作段落） 第一段变成了一段。 在此代码部分中，实际段落数会减少， 最终输出（通过其他应用程序运行后）还包含减少的段落数，这就是问题所在。

当我们通读修订版时，红色段落结束标记+第二段作为一个修订版。 即使该修订版有多个段落，它也是一个修订版。 如果我们对插入的段落应用了单独的段落样式，则在运行此代码后，修订版获得了一种样式，即立即 段落的风格。这一切都是因为那个插入的段落结束标记。

我尝试遍历单词段落，因为我想要避免更改文档中的段落数。 （尝试从下到上，从上到下）但这并没有解决我的问题。

我也曾尝试将修订版分成两个修订版，当

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

但我无法将范围应用于新版本。

现在，如果我们在内容中识别出段落结尾标记，我想将修订分成几部分，并分别应用 如果可能的话。因此，添加字段后，段落计数和段落样式都不会改变。

或者，有没有办法接受所有被标记为插入到 word 文档中的段落结尾标记（仅）？

谁能帮我继续编写代码，如果你有其他想法，请告诉我。

提前谢谢你。

Answer 1

跟踪更改关闭，以下代码示例循环Revisions 并检查第一个字符是否为段落标记。如果是……

实例化了两个Range 对象，一个用于在跟踪更改期间插入的段落之前的段落，另一个用于跟踪更改的段落。这是必要的，因为Revision.Range 在代码进行更改时变得无效。两个段落的样式都已注明。

然后在第一个段落之后立即插入一个附加段落，这会将两个段落都从修订版中删除。正确的样式应用于第一段，轨道改变段落，然后删除额外插入的段落。

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