VBA Word 宏在页脚中查找文本已实现并打印到文本文件不太有效

编程问答 2022-05-28

问题描述

我正在添加我之前请求帮助的一些代码，试图赋予它在页脚中编辑修订号的功能，直到我尝试让它将部分和页面打印到文本文档为止。然后它给出上一次搜索找到的最后一个结果，并打破循环？

这是完整的代码。

Sub MegaMacro()
    
    sword = InputBox("Enter the Rev. no.","Rev. No.","")
    Dim doc As Word.Document,rng As Word.Range
    Dim FileNum As Integer
    Dim oFile As String
    
    On Error GoTo ERRORHANDLER
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    FileNum = FreeFile()
    oFile = doc.Path & "\AuthorTec_Edits.txt"
    If Dir(oFile,vbnormal) <> vbNullString Then
        Kill oFile
    End If
    Open oFile For Append As #FileNum
    Print #FileNum,"Extra spaces between words on Section:Page:"
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        'Here is where it is actually looking for spaces between words
        .Text = " [ ]@([! ])"
        'This line tells it to replace the excessive spaces with one space
        .Replacement.Text = " \1"
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        'execute the replace
        While .Execute
           Print #FileNum,rng.information(wdActiveEndSectionNumber) & ":" & rng.information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
        
        ' Remove white space at the beginning of lines
    Print #FileNum,"Extra white space at beginning of lines on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = "^p^w"
        .Replacement.Text = "^p"
        While .Execute
           Print #FileNum,rng.information(wdActiveEndSectionNumber) & ":" & rng.information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

' Removes spaces in first line
    Print #FileNum,"Removed spaces in first line on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = " {3,}"
        .Replacement.Text = ""
        While .Execute
           Print #FileNum,rng.information(wdActiveEndSectionNumber) & ":" & rng.information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

    Print #FileNum,"Removed excessive spaces after a paragraph mark on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        'This time its looking for excessive spaces after a paragraph mark
        .Text = "^p "
        'What to replace it with
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        While .Execute
           Print #FileNum,rng.information(wdActiveEndSectionNumber) & ":" & rng.information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
    
    'search for bullet1s with full stops
    Print #FileNum,"Removed Bullet 1s on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Bullet 1")
        .Replacement.ClearFormatting
        .Text = ".^p"
        .Replacement.Text = ".^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        While .Execute
           Print #FileNum,rng.information(wdActiveEndSectionNumber) & ":" & rng.information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
           Wend
        End With
           
               'search for bullet2s with full stops
    Print #FileNum,"Removed Bullet 2s on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Bullet 2")
        .Replacement.ClearFormatting
        .Text = ".^p"
        .Replacement.Text = ".^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        While .Execute
           Print #FileNum,rng.information(wdActiveEndSectionNumber) & ":" & rng.information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
    
    Dim myStoryRange As Range

        Print #FileNum,"Replaced Rev. No's on Section:Page:"
        For Each myStoryRange In ActiveDocument.StoryRanges
        With myStoryRange.Find
            .Text = "Rev. ^?^?.^?^?"
            .Replacement.Text = "Rev. " & sword
            .Wrap = wdFindStop
            While .Execute
           Print #FileNum,myStoryRange.information(wdActiveEndSectionNumber) & ":" & myStoryRange.information(wdActiveEndAdjustedPageNumber)
           Wend
        End With
        do while Not (myStoryRange.NextStoryRange Is nothing)
            Set myStoryRange = myStoryRange.NextStoryRange
            With myStoryRange.Find
                .Text = "Rev. ^?^?.^?^?"
                .Replacement.Text = "Rev. " & sword
                .Wrap = wdFindStop
                While .Execute
                Print #FileNum,myStoryRange.information(wdActiveEndSectionNumber) & ":" & myStoryRange.information(wdActiveEndAdjustedPageNumber)
                Wend
            End With
        Loop
    Next myStoryRange
    
    

ERRORHANDLER:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCr & Err.Description,vbCritical
        Err.Clear
    Else
        MsgBox "Action Complete"
    End If
    If FileNum <> 0 Then Close #FileNum

End Sub

这部分没有按预期工作，尽管如果我删除 while 循环，而是使用 .Execute Replace:=wdReplaceAll 它按预期工作，无需任何报告。

    Dim myStoryRange As Range

        Print #FileNum,myStoryRange.information(wdActiveEndSectionNumber) & ":" & myStoryRange.information(wdActiveEndAdjustedPageNumber)
                Wend
            End With
        Loop
    Next myStoryRange

感谢任何帮助。

解决方法

尝试这样的事情：

Dim doc As Word.Document
Dim rng As Word.Range
Dim Sec As Word.Section
Dim HF As Word.HeaderFooter

Set doc = ActiveDocument
For Each Sec In doc.Sections
    For Each HF In Sec.Footers
        If HF.LinkToPrevious = False Then
            Set rng = HF.Range
            With rng.Find
                .ClearFormatting
                .Text = "Rev. ^?^?.^?^?"
                .Forward = True
                .Wrap = wdFindStop
                .MatchWildcards = True
                .Execute
                If .found Then
                    rng.Text = "New Rev Text"
                    Print #FileNum,rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
                End If
            End With
        End If
    Next
Next

编辑：由原始问题海报 我为这个例子创建了一个单独的宏，使用上面的代码。

Sub RevReplacer()


Dim doc As Word.Document
Dim rng As Word.Range
Dim Sec As Word.Section
Dim HF As Word.HeaderFooter
Dim oFile As String
sword = InputBox("Enter the Rev. no.","Rev. No.","")
Set doc = ActiveDocument

FileNum = FreeFile()
oFile = doc.Path & "\AuthorTec_Edits.txt"
If Dir(oFile,vbNormal) <> vbNullString Then
Kill oFile
End If

Open oFile For Append As #FileNum
For Each Sec In doc.Sections
    For Each HF In Sec.Footers
        If HF.LinkToPrevious = False Then
            Set rng = HF.Range
            With rng.Find
                .ClearFormatting
                .Text = "Rev. ^?^?.^?^?"
                .Forward = True
                .Wrap = wdFindStop
                .MatchWildcards = False
                .Execute
                If .Found Then
                    rng.Text = "rev. " & sword
                    Print #FileNum,rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
                End If
            End With
        End If
    Next
Next

End Sub

它正确执行了替换，但仍然没有将任何内容打印到文本文件中，我觉得我没有使用打印功能调用错误的对象？

@RichMichaels 回应...

删除 If HF.LinkToPrevious ... 语句并删除结束的 End If。由于某种未知原因，这导致例程跳过仅首页和偶数页脚。

将 Print 语句更改为如下所示：

Print #FileNum,"Section " & Sec.Index & " Revision Date Changed Page: " & HF.Index
ms-word