VBA Word - 有条件地接受页眉和页脚的更改

Question

由于我们的技术写作和工程审查团队的 MS-Word 熟练程度变化，我正在编写一个 Sub 来清理“跟踪更改”文档。

基本上在 Document_Open 事件的后面，我循环遍历所有 StoryRanges 检查 Revision.Type 和 Accept 或 根据更改的枚举值（.Type 1、2 或 9）什么都不做。我也在文档中的 Headers 和 Footers 中执行此操作。

让我烦恼的是，它可以在文档的主体部分工作，但我无法选择性地接受页眉或页脚中的任何更改。

'Public Declarations
Public Sctn as Section
Public NewRevision as Revision
Public StorySect as Object
Public HdFt as HeaderFooter'

'Conditionlly Accept Changes in Document
    Public Sub Document_AcceptAll()

    On Error GoTo RevErr

    'Body
    For Each StorySect In ActiveDocument.StoryRanges 
        For Each NewRevision In ActiveDocument.Revisions
            Select Case ThisDocument.NewRevision.Type
                Case Is <> 1, 2 Or 9    '1: wdRevisionInsert  2: wdRevisionDelete  9: wdRevisionReplace
                    ThisDocument.NewRevision.Accept

                Case Else

            End Select

        Next NewRevision
    Next StorySect '<<

    'Header & Footers
    With ActiveDocument
        'Loop thru all Sections
        For Each Sctn In .Sections
            'Loop thru all Headers in Section
            For Each HdFt In Sctn.Headers
                With HdFt
                    For Each NewRevision In ActiveDocument.Revisions                            
                        Select Case ThisDocument.NewRevision.Type
                            Case Is <> 1, 2 Or 9    '1: wdRevisionInsert  2: wdRevisionDelete  9: wdRevisionReplace
                                ThisDocument.NewRevision.Accept
                            Case Else
                        End Select
                    Next NewRevision
                End With
            Next HdFt

            'Loop thru all Footers in Section
            For Each HdFt In Sctn.Footers
                With HdFt
                    For Each NewRevision In ActiveDocument.Revisions
                        Select Case ThisDocument.NewRevision.Type
                            Case Is <> 1, 2 Or 9    '1: wdRevisionInsert  2: wdRevisionDelete  9: wdRevisionReplace
                                ThisDocument.NewRevision.Accept
                            Case Else
                        End Select
                        Next NewRevision
                  End With    
            Next HdFt

        Next Sctn
    End With

lbl_Exit:
        Exit Sub
RevErr:
        If Err.Number <> 5852 Then
            Err.Clear
            GoTo lbl_Exit
        Else
            Err.Clear
            Resume
        End If
    End Sub

一个简单的解决方案是在最终发布之前忽略它并运行 AcceptAll 子，但随后我松开了更改栏，如果团队被要求手动添加更改栏，我认为我无法获得可重复的结果。

似乎还有另一种方法，对每个部分都有一个 SeekView 循环，然后嵌套有条件的 Revision.Type，但对于这个应用程序来说，这似乎是多余的。

任何其他方法将不胜感激，请记住，文档实例之间的节数会有所不同。

https://docs.microsoft.com/en-us/office/vba/api/word.wdrevisiontype

Accept Formatting Changes in Word Headers, Footers and Main Document

Answer 1

显示的代码没有在页眉/页脚中获取任何修订的原因是，理想情况下，Revisions 应该在范围上进行查询，而不仅仅是在 ActiveDocument 或 @987654324 上@ 或 Footer。第一个案例似乎对您有用，至少在正在测试的文档上，尽管我希望它会错过文本框中的任何修订。

此外，应该可以通过循环StoryRanges 来获取页眉和页脚。请参阅documentation 中的最后一个示例。问题中显示的代码缺少的是在循环中使用NextStoryRange。

以下代码 sn-p 演示了这两个建议。在StoryRange 上查询Revisions，代码在文档中循环all StoryRanges。 （请注意，“在现实世界中”，我可能会将循环内重复的代码放在一个单独的过程中，并在两个地方调用该过程，而不是复制所有代码。）

Public Sub Document_AcceptAll()

'Public Declarations
    Dim Sctn As Section
    Dim NewRevision As Revision
    Dim StorySect As Word.Range
    Dim HdFt As HeaderFooter

    On Error GoTo RevErr

    For Each StorySect In ActiveDocument.StoryRanges
        'Debug.Print StorySect.StoryType
        For Each NewRevision In StorySect.Revisions
            Select Case NewRevision.Type
                Case Is <> 1, 2 Or 9    '1: wdRevisionInsert  2: wdRevisionDelete  9: wdRevisionReplace
                    NewRevision.Accept

                Case Else

            End Select

        Next NewRevision
        Do While Not (StorySect.NextStoryRange Is Nothing)
            Set StorySect = StorySect.NextStoryRange

            For Each NewRevision In StorySect.Revisions
                Select Case NewRevision.Type
                    Case Is <> 1, 2 Or 9    '1: wdRevisionInsert  2: wdRevisionDelete  9: wdRevisionReplace
                        NewRevision.Accept

                    Case Else

                End Select

            Next NewRevision
        Loop
        Next StorySect '<<

lbl_Exit:
        Exit Sub
RevErr:
        If Err.Number <> 5852 Then
            Err.Clear
            GoTo lbl_Exit
        Else
            Err.Clear
            Resume
        End If
End Sub