All the following is based on the code I posted in:
https://www.msofficeforums.com/117894-post9.html
Code:
Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Application.ScreenUpdating = True
End Sub
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
RecurseWriteFolderName (SubFolder)
Next
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 UpdateDocuments(oFolder As String)
Dim strFldr As String, strFile As String, wdDoc As Document
Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter, Shp As Shape
strFldr = oFolder
If strFldr = "" Then Exit Sub
strFile = Dir(strFldr & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=False)
With wdDoc
'Loop through all story ranges
For Each Rng In .StoryRanges
Call FndRepRng(Rng)
For Each Shp In Rng.ShapeRange
If Not Shp.TextFrame Is Nothing Then
Call FndRepRng(Shp.TextFrame.TextRange)
End If
Next
Next
'Loop through all headers & footers
For Each Sctn In .Sections
For Each HdFt In Sctn.Headers
With HdFt
If .Exists = True Then
If .LinkToPrevious = False Then
Call FndRepRng(HdFt.Range)
For Each Shp In .Shapes
If Not Shp.TextFrame Is Nothing Then
Call FndRepRng(Shp.TextFrame.TextRange)
End If
Next
End If
End If
End With
Next
For Each HdFt In Sctn.Footers
With HdFt
If .Exists = True Then
If .LinkToPrevious = False Then
Call FndRepRng(HdFt.Range)
For Each Shp In .Shapes
If Not Shp.TextFrame Is Nothing Then
Call FndRepRng(Shp.TextFrame.TextRange)
End If
Next
End If
End If
End With
Next
Next
'Create a PDF of the document
.SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'Save and close the document
.Close SaveChanges:=wdSaveChanges
End With
strFile = Dir()
Wend
Set wdDoc = Nothing
End Sub
Sub FndRepRng(Rng As Range)
With Rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindContinue
.Text = "REVISION A"
.Replacement.Text = "REVISION B"
.Execute Replace:=wdReplaceAll
.Text = "1 APRIL 1776"
.Replacement.Text = "31 DECEMBER 1492"
.Execute Replace:=wdReplaceAll
End With
End Sub