Option Explicit

Public Sub BatchReplaceAll()

Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
Dim myStoryRange As Range

PathToUse = "C:\Test\"

'Error handler to handle error generated whenever
'the FindReplace dialog is closed

On Error Resume Next

'Close all open documents before beginning

Documents.Close SaveChanges:=wdPromptToSaveChanges

'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document

FirstLoop = True

'Set the directory and type of file to batch process

myFile = Dir$(PathToUse & "*.doc")

While myFile <> ""

    'Open document
    Set myDoc = Documents.Open(PathToUse & myFile)

    If FirstLoop Then

        'Display dialog on first loop only

        Dialogs(wdDialogEditReplace).Show

        FirstLoop = False

        Response = MsgBox("Do you want to process the rest of the files in this folder", vbYesNo)
        If Response = vbNo Then Exit Sub

    Else

        'On subsequent loops (files), a ReplaceAll is
        'executed with the original settings and without
        'displaying the dialog box again
For Each myStoryRange In ActiveDocument.StoryRanges
   If myStoryRange.StoryType <> wdMainTextStory Then
        With Dialogs(wdDialogEditReplace)
            .ReplaceAll = 1
            .Execute
        End With
    
       Do While Not (myStoryRange.NextStoryRange Is Nothing)
         Set myStoryRange = myStoryRange.NextStoryRange
          With Dialogs(wdDialogEditReplace)
            .ReplaceAll = 1
            .Execute
            End With
        Loop
    End If
Next myStoryRange

    End If

    'Close the modified document after saving changes

    myDoc.Close SaveChanges:=wdSaveChanges

    'Next file in folder

    myFile = Dir$()

Wend

End Sub

Sub ReplaceTextInHeader()
Dim oHF As HeaderFooter
Dim oSection As Section
Dim myfle
PathToUse As String
PathToUse = "C:\Test\"
myfile = Dir(PathToUse & "*.doc")
Do While myfle <> ""
  Documents.Open (PathToUse & myfile)
     For Each oSection In ActiveDocument.Sections
        For Each oHF In oSection.Headers
           oHF.Range.Text = Replace(oHF.Range.Text, "Revision", "Final")
        Next
     Next
  ActiveDocument.Close SaveChanges:=wdSaveChanges
  myfile = Dir()
Loop
End Sub

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc.StoryRanges(wdPrimaryHeaderStory).Find
    .ClearFormatting
    .Text = InputBox("Text to Replace", "Old String")
    .Replacement.Text = InputBox("Replacement Text", "New String")
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = True
    .MatchWholeWord = True
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
  End With
  wdDoc.Close SaveChanges:=True
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim strFnd As String, strRep As String, wdStory(), i As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFnd = InputBox("Text to Replace", "Old String")
strFile = Dir(strFolder & "\*.doc", vbNormal)
strRep = InputBox("Replacement Text", "New String")
wdStory = Array(wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    On Error Resume Next
    For i = LBound(wdStory) To UBound(wdStory)
      MsgBox wdStory(i)
      With .StoryRanges(wdStory(i)).Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strFnd
        .Replacement.Text = strRep
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
    Next
    On Error GoTo 0
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub