search and replace, save, convert to PDF, recursively

[mbcohn]

So, I have a bunch of nested folders full of Word files.


My goal here is to loop through all the folders, go to each Word file, do a search and replace operation, save the word file, then export a PDF version of that Word file, then move on.


To attempt this, I have cobbled together some answers that I got on this forum to previous questions. But when I run the code, it just hangs, and I have to 'end task' on Word (and it doesn't actually process any documents, as far as I can tell.) What am I doing wrong?

 Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String
 
Sub RecursiveDocuments()
' This recursively goes through a tree of folders
' and does something
Application.ScreenUpdating = False
Dim TopLevelFolder As String
Dim TheFolders As Variant, aFolder As Variant
Dim strFile As String, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If TopLevelFolder = "" Then Exit Sub
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))
strFile = Dir(CStr(Split(StrFolds, vbCr)(i)) & "\*.doc", vbNormal)
Do While strFile <> ""

batchSpecsUpdate

Loop
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 specsUpdate()
'
' specsUpdate Macro
'
'


    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "REVISION A"
        .Replacement.Text = "REVISION B"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "1 APRIL 1776"
        .Replacement.Text = "31 DECEMBER 1492"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub batchSpecsUpdate()



 'Written by Richard V. Michaels, Office Apps and Services MVP
    'http://www.greatcirclelearning.com
    'Browse for files to update
    Dim i As Integer, selFiles() As String
    Dim strFolderPath As String, Sep As String
    Sep = Application.PathSeparator
    Erase selFiles
    #If Mac Then
        Dim iPath As String, iScript As String, iFiles As String
        Dim iSplit As Variant, N As Long, FileFormat As String
        FileFormat = "{""org.openxmlformats.wordprocessingml.document"",""com.microsoft.word.doc""," & _
            """org.openxmlformats.wordprocessingml.document.macroenabled""}"
        On Error Resume Next
        iPath = MacScript("return (path to documents folder) as String")
        If Application.Version < 15 Then
            'Mac Office 2011
            iScript = "set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _
                "set theFiles to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Select the files to update"" default location alias """ & _
                iPath & """ with multiple selections allowed) as string" & vbNewLine & _
                "set applescript's text item delimiters to """" " & vbNewLine & _
                "return theFiles"
        Else
            'Mac Office 2016
            iScript = "set theFiles to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Select the files to update"" default location alias """ & _
                iPath & """ with multiple selections allowed)" & vbNewLine & _
                "set thePOSIXFiles to {}" & vbNewLine & _
                "repeat with aFile in theFiles" & vbNewLine & _
                "set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
                "end repeat" & vbNewLine & _
                "set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
                "set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
                "set text item delimiters to TID" & vbNewLine & _
                "return thePOSIXFiles"
        End If
        iFiles = MacScript(iScript)
        On Error GoTo 0
        If iFiles <> "" Then
            iSplit = Split(iFiles, Chr(10))
            ReDim Preserve selFiles(UBound(iSplit))
            strFolderPath = Left(iSplit(0), InStrRev(iSplit(0), Sep))
            For N = LBound(iSplit) To UBound(iSplit)
                selFiles(N) = iSplit(N)
            Next N
        Else
            Exit Sub
        End If
    #Else
        'Windows Office 2016, 2013, 2010, 2007
        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "Select the files to update"
            .InitialFileName = CurDir
            .AllowMultiSelect = True
            .Filters.Clear
            .Filters.Add "All Word Files", "*.docx; *.docm; *.doc", 1
            If .Show = 0 Then
                Exit Sub
            End If
            ReDim Preserve selFiles(.SelectedItems.Count - 1)
            strFolderPath = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), Sep))
            For i = 0 To .SelectedItems.Count - 1
                selFiles(i) = .SelectedItems(i + 1)
            Next
            .Filters.Clear
        End With
    #End If

    Dim doc As Word.Document, FirstTime As Boolean

    FirstTime = True
    On Error GoTo errHandler

    For i = 0 To UBound(selFiles)
        'The following is setup to perform a conditional first time check
        'Depending on your exact requirements, you may not need it.
        If FirstTime = True Then
            Set doc = Documents.Open(FileName:=selFiles(i))

            'This is where you will insert your code for applying the edits
            'you want to perform
            specsUpdate
            Word_ExportPDF

            doc.Save
            
            
            
            DoEvents
            FirstTime = False
        Else
            On Error GoTo 0
            Set doc = Documents.Open(FileName:=selFiles(i))

            'This is where you will insert your code for replicating the edits
            'you made to the first document
            specsUpdate
            Word_ExportPDF


            doc.Close Word.WdSaveOptions.wdSaveChanges
            DoEvents
        End If
    Next

    MsgBox "Update Complete. Your original document remains open.", vbInformation, "Success"
errHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "Uh-Oh!"
    End If
End Sub

Sub Word_ExportPDF()
'PURPOSE: Generate A PDF Document From Current Word Document
'NOTES: PDF Will Be Saved To Same Folder As Word Document File
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean

UniqueName = False

'Store Information About Word File
  myPath = ActiveDocument.FullName
  CurrentFolder = ActiveDocument.Path & "\"
  FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

'Does File Already Exist?
'If so, too bad
'  Do While UniqueName = False
 '   DirFile = CurrentFolder & FileName & ".pdf"
  '  If Len(Dir(DirFile)) <> 0 Then
   '   UserAnswer = MsgBox("File Already Exists! Click " & _
    '   "[Yes] to override. Click [No] to Rename.", vbYesNoCancel)
      
     ' If UserAnswer = vbYes Then
        UniqueName = True
 '     ElseIf UserAnswer = vbNo Then
 '       Do
 '         'Retrieve New File Name
 '           FileName = InputBox("Provide New File Name " & _
 '            "(will ask again if you provide an invalid file name)", _
 '            "Enter File Name", FileName)
          
          'Exit if User Wants To
  '          If FileName = "False" Or FileName = "" Then Exit Sub
  '      Loop While ValidFileName(FileName) = False
  '    Else
   '     Exit Sub 'Cancel
   '   End If
   ' Else
   '   UniqueName = True
   ' End If
'  Loop
  
'Save As PDF Document
  On Error GoTo ProblemSaving
    ActiveDocument.ExportAsFixedFormat _
     OutputFileName:=CurrentFolder & FileName & ".pdf", _
     ExportFormat:=wdExportFormatPDF
  On Error GoTo 0

'Confirm Save To User
  With ActiveDocument
    FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
  End With
  
 ' MsgBox "PDF Saved in the Folder: " & FolderName

Exit Sub

'Error Handlers
ProblemSaving:
  MsgBox "There was a problem saving your PDF. This is most commonly caused" & _
   " by the original PDF file already being open."
  Exit Sub

End Sub

Function ValidFileName(FileName As String) As Boolean
'PURPOSE: Determine If A Given Word Document File Name Is Valid
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim TempPath As String
Dim doc As Document

'Determine Folder Where Temporary Files Are Stored
  TempPath = Environ("TEMP")

'Create a Temporary XLS file (XLS in case there are macros)
  On Error GoTo InvalidFileName
    Set doc = ActiveDocument.SaveAs2(ActiveDocument.TempPath & _
     "\" & FileName & ".doc", wdFormatDocument)
  On Error Resume Next

'Delete Temp File
  Kill doc.FullName

'File Name is Valid
  ValidFileName = True

Exit Function

'ERROR HANDLERS
InvalidFileName:
'File Name is Invalid
  ValidFileName = False

End Function

Sub UpdateDocuments()
' This accepts changes on all files in a directory.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document, Rng As Range
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      For Each Rng In .StoryRanges
        Rng.Revisions.AcceptAll
      Next
      .Close SaveChanges:=True
    End With
  End If
  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 batchWordToPDF()



 'Written by Richard V. Michaels, Office Apps and Services MVP
    'http://www.greatcirclelearning.com
    'Browse for files to update
    Dim i As Integer, selFiles() As String
    Dim strFolderPath As String, Sep As String
    Sep = Application.PathSeparator
    Erase selFiles
    #If Mac Then
        Dim iPath As String, iScript As String, iFiles As String
        Dim iSplit As Variant, N As Long, FileFormat As String
        FileFormat = "{""org.openxmlformats.wordprocessingml.document"",""com.microsoft.word.doc""," & _
            """org.openxmlformats.wordprocessingml.document.macroenabled""}"
        On Error Resume Next
        iPath = MacScript("return (path to documents folder) as String")
        If Application.Version < 15 Then
            'Mac Office 2011
            iScript = "set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _
                "set theFiles to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Select the files to update"" default location alias """ & _
                iPath & """ with multiple selections allowed) as string" & vbNewLine & _
                "set applescript's text item delimiters to """" " & vbNewLine & _
                "return theFiles"
        Else
            'Mac Office 2016
            iScript = "set theFiles to (choose file of type" & _
                " " & FileFormat & " " & _
                "with prompt ""Select the files to update"" default location alias """ & _
                iPath & """ with multiple selections allowed)" & vbNewLine & _
                "set thePOSIXFiles to {}" & vbNewLine & _
                "repeat with aFile in theFiles" & vbNewLine & _
                "set end of thePOSIXFiles to POSIX path of aFile" & vbNewLine & _
                "end repeat" & vbNewLine & _
                "set {TID, text item delimiters} to {text item delimiters, ASCII character 10}" & vbNewLine & _
                "set thePOSIXFiles to thePOSIXFiles as text" & vbNewLine & _
                "set text item delimiters to TID" & vbNewLine & _
                "return thePOSIXFiles"
        End If
        iFiles = MacScript(iScript)
        On Error GoTo 0
        If iFiles <> "" Then
            iSplit = Split(iFiles, Chr(10))
            ReDim Preserve selFiles(UBound(iSplit))
            strFolderPath = Left(iSplit(0), InStrRev(iSplit(0), Sep))
            For N = LBound(iSplit) To UBound(iSplit)
                selFiles(N) = iSplit(N)
            Next N
        Else
            Exit Sub
        End If
    #Else
        'Windows Office 2016, 2013, 2010, 2007
        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "Select the files to update"
            .InitialFileName = CurDir
            .AllowMultiSelect = True
            .Filters.Clear
            .Filters.Add "All Word Files", "*.docx; *.docm; *.doc", 1
            If .Show = 0 Then
                Exit Sub
            End If
            ReDim Preserve selFiles(.SelectedItems.Count - 1)
            strFolderPath = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), Sep))
            For i = 0 To .SelectedItems.Count - 1
                selFiles(i) = .SelectedItems(i + 1)
            Next
            .Filters.Clear
        End With
    #End If

    Dim doc As Word.Document, FirstTime As Boolean

    FirstTime = True
    On Error GoTo errHandler

    For i = 0 To UBound(selFiles)
        'The following is setup to perform a conditional first time check
        'Depending on your exact requirements, you may not need it.
        If FirstTime = True Then
            Set doc = Documents.Open(FileName:=selFiles(i))

            'This is where you will insert your code for applying the edits
            'you want to perform

            Word_ExportPDF

            doc.Save
            
            
            
            DoEvents
            FirstTime = False
        Else
            On Error GoTo 0
            Set doc = Documents.Open(FileName:=selFiles(i))

            'This is where you will insert your code for replicating the edits
            'you made to the first document
            specsUpdate
            Word_ExportPDF


            doc.Close Word.WdSaveOptions.wdSaveChanges
            DoEvents
        End If
    Next

    MsgBox "Update Complete. Your original document remains open.", vbInformation, "Success"
errHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "Uh-Oh!"
    End If
End Sub

[Guessed]

It doesn't help to debug this when you include lines to ignore errors.

Are you running this code on a Mac or a Windows machine?
Do you have subfolders containing .doc Word documents in the folder you pick? It looks like your code ignores .docx and .docm files.
Is it ignoring the top level of the picked folder? I haven't looked closely at that but it might ONLY be looking at subfolders.

[macropod]

Originally Posted by Guessed

It looks like your code ignores .docx and .docm files.

Using Dir(*.doc, vbNormal) as the OP has done returns .doc, .docx and .docm files.

[macropod]

All the following is based on the code I posted in: https://www.msofficeforums.com/117894-post9.html

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

[gmaxey]

Paul,


Not saying it is any better and in fact may be less efficient, but just posting as an alternative. I do seem to recall at one point I was using a method similar to yours for picking a folder and it was giving someone fits so I changed to the dialog used here:

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

[mbcohn]

macropod, thanks for revising your code.
This seems to work well on several directories, and then it gives the error:
"Run time error 5917: This object does not support attached text."
The code stops on

 Call FndRepRng(Shp.TextFrame.TextRange)

[macropod]

Without access to the document concerned, it's impossible for me to say. Can you attach that document to a post (delete anything sensitive)? You can do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

[mbcohn]

I'm sorry, but there's just no way. Also, I'm not even sure how to tell which document it was. No document was open when the error came up, except the generic document that I opened to call the code.


However, after some trial and error, I'm pretty sure that the issue has to do with switching directories. If I apply this code to a single directory, it works fine. If I apply it to a directory containing other directories, it does just the first directory that contains Word files, and then stops with the error message.

[macropod]

When the code errored out, the problem document should have been listed on the left side of the VBE. Furthermore, if you examine the folders being processed, there should be a PDF for the last document whose processing completed; the problem one will be the next document after that. Otherwise, change:

Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=False)

to:

Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=True)

and re-run the macro

[mbcohn]

Okay. The problem document contains an auto-generated table of contents. That's one thing different about it. It's also the last document in the folder. And the PDF of it was generated, although the search and replace didn't seem to happen.

[macropod]

Unless your Table of Contents is in a textbox (most unlikely), or it's capturing a reference to a textbox anchored to a heading somewhere else in your document (possible, but unlikely), that cannot have anything to do with the error.

[mbcohn]

Okay, well... that change didn't make any difference. I'm pretty sure there is not a text box in that problem file, but not 100% sure. So, I'm just going one directory at a time now.


Also, I see that the code includes a textbox announcing the end of the process, and that doesn't come up.

[macropod]

Originally Posted by mbcohn

I see that the code includes a textbox announcing the end of the process, and that doesn't come up.

That's to be expected if the macro is crashing.

As for the crashes themselves, try replacing all instances of:
If Not Shp.TextFrame Is Nothing Then
with:
If Shp.Type = msoTextBox Then

[mbcohn]

Well, this time it ran for a lot longer. Then it stopped at a run-time error 9105: String is longer than 255 characters. It was on this line.

 Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=True)

Well, the folders I'm working with are already nested within a series of other folders, so I suppose the file names, when they include the path, can get rather long.

[macropod]

In which case, I suggest temporarily moving the problem folders to another folder nearer the root so the path isn't so long.