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

Question

我正在使用 VBA 对“已应用字轨更改”文档进行更改。

红色段落结束标记是插入段落结束标记。(打开“跟踪更改”> 将光标放在第一段末尾 > 按 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

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

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

我尝试通过单词 paragraphs 移动，因为我想要的是避免更改文档中的段落计数。(尝试从下到上，从上到下)但这并没有解决我的问题。

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

 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