Option Explicit
Dim m_oFSO As Object
Dim m_colFolders As New Collection
Dim m_oFld As Object
Dim m_oDoc As Document
Sub Main()
Dim oRootFld As Object
Dim lngFld As Long
Dim strFolder As String
  strFolder = fcnBrowseForFolder
  If Not strFolder = vbNullString Then
    If m_oFSO Is Nothing Then Set m_oFSO = CreateObject("Scripting.FileSystemObject")
    Set oRootFld = m_oFSO.GetFolder(strFolder)
    m_colFolders.Add oRootFld.Path, oRootFld.Path
    CollectSubFolders oRootFld
    For lngFld = 1 To m_colFolders.Count
      Set m_oFld = m_oFSO.GetFolder(m_colFolders(lngFld))
      If m_oFld.Files.Count > 0 Then modMe.ProcessFolderDocuments
    Next lngFld
  Else
    MsgBox "You must select a root folder for processing.", vbInformation + vbOKOnly, "NO FOLDER SELECTED"
  End If
lbl_Exit:
  Set m_colFolders = Nothing
  Exit Sub
End Sub
Sub CollectSubFolders(oFolder As Object)
Dim oSubFolder As Object
  On Error GoTo Err_Handler
  For Each oSubFolder In oFolder.SubFolders
    m_colFolders.Add oSubFolder.Path, oSubFolder.Path
    Set oFolder = m_oFSO.GetFolder(oSubFolder.Path)
    CollectSubFolders oSubFolder
Err_ReEntry:
  Next
  On Error GoTo 0
  Exit Sub
Err_Handler:
  Debug.Print oSubFolder.Name & " " & Err.Number & "" & Err.HelpContext
  Resume Err_ReEntry
End Sub
Public Function fcnBrowseForFolder(Optional strTitle As String = "Select folder ...") As String
Dim oDlg As FileDialog
Dim strFolder As String
  Set oDlg = Application.FileDialog(msoFileDialogFolderPicker)
  strFolder = vbNullString
  With oDlg
    .Title = strTitle
    If .Show = -1 Then strFolder = .SelectedItems(1) & Application.PathSeparator
  End With
  fcnBrowseForFolder = strFolder
lbl_Exit:
  Set oDlg = Nothing
  Exit Function
End Function

Sub ProcessFolderDocuments()
Dim oFile As Object
  For Each oFile In m_oFld.Files
    Select Case oFile.Type
      Case "Microsoft Word Macro-Enabled Document", "Microsoft Word Document", "Microsoft Word 97 - 2003 Document"
        Set m_oDoc = Documents.Open(FileName:=oFile.Path, AddToRecentFiles:=False, ReadOnly:=False, Visible:=False)
        DocumentProcess
    End Select
  Next oFile
lbl_Exit:
  Exit Sub
End Sub

Sub DocumentProcess()
Dim rngStory As Range, oShp As Shape, oCanShp As Shape
Dim lngJunk As Long
  With m_oDoc
    lngJunk = .Sections(1).Headers(1).Range.StoryType
    'Iterate through all story types in the current document
    For Each rngStory In .StoryRanges
      'Iterate through all linked stories
      Do
        FndRepRng rngStory
        On Error Resume Next
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If Not oShp.TextFrame.TextRange Is Nothing Then
                  FndRepRng oShp.TextFrame.TextRange
                End If
                If oShp.Type = msoCanvas Then
                  For Each oCanShp In oShp.CanvasItems
                    If oCanShp.TextFrame.HasText Then
                      FndRepRng oCanShp.TextFrame.TextRange
                    End If
                  Next oCanShp
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    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
lbl_Exit:
  Exit Sub
End Sub
Sub FndRepRng(oRng As Range)
  With oRng.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
lbl_Exit:
  Exit Sub
End Sub