Question

我想在文档的每次音轨变化的开始和结尾处添加两个单词字段。

我正在使用for-each循环遍历单词修订版。

下面是我的代码：

Private Function TrackChangesOnDeletions(ByRef WordRange As Word.Range)

On Error GoTo ErrorHandler

Dim fTrackRevisions As Boolean
Dim objRevision As Word.Revision
Dim objContentControl As Word.ContentControl
Dim objRange As Word.Range
Dim objField As Word.Field
Dim index As Long

Dim objRangeCopy As Word.Range
Dim objFieldEnd As Word.Field

With WordRange.Document
    fTrackRevisions = .TrackRevisions
    .TrackRevisions = False
End With

With WordRange
   For Each objRevision In .Revisions
       On Error Resume Next
       With objRevision
           Set objRange = .Range

           'Make sure there's no break character that may exist at the end of the specified range,
           'in order to avoid end field appears at the beginning of the next line.
           If Len(.Range.Text) > 0 Then
               Select Case Asc(WordRange.Characters.Last)
                   Case 7, 10, 11, 12, 13, 14
                       .Range.MoveEnd Unit:=WdUnits.wdCharacter, Count:=-1
               End Select
           End If

           'Create a copy of the passed range.
           Set objRangeCopy = .Range.Duplicate
           With objRangeCopy
               .Collapse wdCollapseEnd
               'Ensure we are not at an end-of-row marker.
               Do While .Information(wdAtEndOfRowMarker) = True
                   .MoveEnd Unit:=WdUnits.wdCharacter, Count:=1
                   .Collapse wdCollapseEnd
               Loop
           End With

           'Create a new field at the specified range.
           Set objFieldEnd = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, PreserveFormatting:=False)
           'Insert end tag
           objFieldEnd.Code.InsertAfter " >"

           Set objRangeCopy = .Range.Duplicate
           objRangeCopy.Collapse Direction:=wdCollapseStart
           objFieldEnd.Update

           'Insert the start tag
           Set objField = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, Text:="Deletion< ", PreserveFormatting:=False)
                objField.Update

           objRange.SetRange Start:=objField.Code.Start - 1, End:=objFieldEnd.Code.End + 3
           objRange.Font.StrikeThrough = True
           objRange.Font.ColorIndex = wdRed

           .Reject
       End With
       Err.Clear

       Set objContentControl = Nothing
    Next objRevision
End With

ErrorHandler:
    WordRange.Document.TrackRevisions = fTrackRevisions
    Set objContentControl = Nothing
    Set objField = Nothing
    Set objRange = Nothing
    Set objRevision = Nothing
    Select Case Err.Number
        Case 0
        Case Else
            ShowUnexpectedError ErrorSource:="TrackChangesOnDeletions" & vbCr & Err.Source
    End Select

End Function

我的问题是，为第一个修订版本执行的代码一旦获得代码，就将第一个修订版本作为下一个修订版本（在for循环的下一个版本中）也是如此，如果修订版本计数保持不变。因此，开始字段和结束字段不断添加到第一个修订版中，这使单词崩溃。

对于以下原始文本，

我需要输出为隐藏域代码时，应显示为：

但是我的代码给出的输出为（我已经手动停止了for循环迭代以进行此捕获，否则它将添加字段和字段并导致单词崩溃）通过进一步的测试，我发现，如果在循环中的修订之前插入了一些文本，则下一个修订将与当前修订相同。因此循环不间断运行，然后崩溃。

任何人都可以告诉我我在做什么错了。

谢谢。

Answer 1

为了在正确的时间退出循环，我使用了以下方法。任何改进或其他答案表示赞赏。

 Private Function TrackChangesOnDeletions(ByRef WordRange As Word.Range)

 On Error GoTo ErrorHandler

    Dim fTrackRevisions As Boolean
    Dim objRevision As Word.Revision
    Dim objRange As Word.Range
    Dim objRangeCopy As Word.Range      
    Dim objFieldStart As Word.Field
    Dim objFieldEnd As Word.Field
    Dim index As Long
    Dim revisionCount As Long

    With WordRange.Document
        fTrackRevisions = .TrackRevisions
        .TrackRevisions = False
    End With

    revisionCount = WordRange.Revisions.Count
    index = 1

    If (revisionCount > 0) Then
        Set objRevision = WordRange.Revisions(index)

        Do While Not objRevision Is Nothing
            If AllowTrackChangesForDeletion(objRevision) = True Then
                On Error Resume Next
                With objRevision
                    Set objRange = .Range

                    'Make sure there's no break character that may exist at the end of the specified range,
                    'in order to avoid end field appears at the beginning of the next line.
                    If Len(objRange.Text) > 0 Then
                        Select Case Asc(objRange.Characters.Last)
                            Case 7, 10, 11, 12, 13, 14
                                objRange.MoveEnd Unit:=WdUnits.wdCharacter, Count:=-1
                        End Select
                    End If

                    'Create a copy of the passed range.
                    Set objRangeCopy = objRange.Duplicate
                    With objRangeCopy
                        .Collapse wdCollapseEnd
                        'Ensure we are not at an end-of-row marker.
                        Do While .Information(wdAtEndOfRowMarker) = True
                            .MoveEnd Unit:=WdUnits.wdCharacter, Count:=1
                            .Collapse wdCollapseEnd
                        Loop
                    End With

                    'Create a new field at the specified range.
                    Set objFieldEnd = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, PreserveFormatting:=False)
                    'Insert end tag
                    objFieldEnd.Code.InsertAfter " >"

                    Set objRangeCopy = objRange.Duplicate
                    objRangeCopy.Collapse Direction:=wdCollapseStart
                    objFieldEnd.Update

                    'Insert the start tag
                    Set objFieldStart = objRangeCopy.Fields.Add(Range:=objRangeCopy, Type:=wdFieldComments, Text:="Deletion< ", PreserveFormatting:=False)
                    objFieldStart.Update

                    objRange.SetRange Start:=objFieldStart.Code.Start - 1, End:=objFieldEnd.Code.End + 3
                    objRange.Font.StrikeThrough = True
                    objRange.Font.ColorIndex = wdRed

                    .Reject
                End With
                Err.Clear

            End If

            'Move to the next revision (unable to use for loop, because it iterates through the first revision everytime and
            'then crash word
            index = index + 1
            If index > revisionCount Then
                Exit Do
            End If
            Set objRevision = WordRange.Revisions(index)
        Loop
    End If


    ErrorHandler:
        WordRange.Document.TrackRevisions = fTrackRevisions
        Set objFieldEnd = Nothing
        Set objFieldStart = Nothing
        Set objRange = Nothing
        Set objRangeCopy = Nothing
        Set objRevision = Nothing
        Select Case Err.Number
            Case 0
            Case Else
                ShowUnexpectedError ErrorSource:="TrackChangesOnDeletions" & vbCr & Err.Source
        End Select

    End Function

添加开始和结束词字段以跟踪更改

1 个答案: