VBA Word Macro to find text in footer(Achieved) and print to text file(Not quite working)

Question

I am adding to some code I previously requested help with, trying to give it the function of editing a revision number in a footer, Which works up until I try to get it to print the section and page to a text document. Then it give the last result found in the previous search, and breaks the loop?

Here is the code in full.

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

And this part is not working as intended, although if I remove the while loop and instead have .Execute Replace:=wdReplaceAll it works as intended without any reporting.

    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

Any help is appreciated.

question from:https://stackoverflow.com/questions/65901537/vba-word-macro-to-find-text-in-footerachieved-and-print-to-text-filenot-quite

Answer 1

Try something like this:

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

Edit: by Original question poster I have created a seperate macro just for this example, using the code above.

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

It correctly performs the replace, but still doesn't print anything at all to the text file, I feel like i'ts calling the wrong objects with the print function?

@RichMichaels Response ...

Remove the If HF.LinkToPrevious ... statement and also remove the closing End If. For some unknown reason, this is causing the routine to skip First Page Only and Even Page Footers.

Change the Print statement to something like the following:

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