#1
|
|||
|
|||
search and replace, save, convert to PDF, recursively
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? Code:
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 |
#2
|
||||
|
||||
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.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
||||
|
||||
Using Dir(*.doc, vbNormal) as the OP has done returns .doc, .docx and .docm files.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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: Code:
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 |
#6
|
|||
|
|||
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 Code:
Call FndRepRng(Shp.TextFrame.TextRange) |
#7
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
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. |
#9
|
||||
|
||||
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:
Code:
Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=False) Code:
Set wdDoc = Documents.Open(FileName:=strFldr & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=False, Visible:=True)
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
|||
|
|||
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.
|
#11
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#12
|
|||
|
|||
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. |
#13
|
||||
|
||||
Quote:
As for the crashes themselves, try replacing all instances of: If Not Shp.TextFrame Is Nothing Then with: If Shp.Type = msoTextBox Then
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#14
|
|||
|
|||
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.
Code:
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. |
#15
|
||||
|
||||
In which case, I suggest temporarily moving the problem folders to another folder nearer the root so the path isn't so long.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
recursive replace pdf |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Need Search and Replace Help w Wildcards | Oberstfunster | Word | 2 | 12-06-2018 09:28 AM |
Search and replace | hernans | Word VBA | 5 | 07-02-2018 07:01 PM |
Wildcards used for Search and Replace | ChrisRick | Word | 2 | 03-09-2017 05:01 AM |
search and replace | dirkoo | Word VBA | 2 | 08-14-2013 11:25 AM |
Search and Replace - Clear Search box | JostClan | Word | 1 | 05-04-2010 08:46 PM |