Getting error while doing mass find n replace in Sub folder

When I am running the below code for n number of document in a folder then it works fine but when i inclde more sub folder with the docs then it shows the error
"Run-time error '5792':
The files appears to be corrupted.

Can someone help? I am not much familier with coding.

Public Sub MassReplace()
    With ApplicationFileSearch
        .LookIn = "C:\Users\milans\Desktop\Procedure - Test"             ' where to search
        .SearchSubFolders = True    ' search the subfolders
        .FileName = "*.docx"         ' file pattern to match

        ' if more than one match, execute the following code
        If .Execute() > 0 Then
            ' for each file you find, run this loop
            For i = 1 To .FoundFiles.Count
                ' open the file based on its index position
                Documents.Open FileName:=.FoundFiles(i), ReadOnly:=False   'I tracked error it is the line where erorr is coming

                ' search and replace the address
                Selection.Find.ClearFormatting
                Selection.Find.Replacement.ClearFormatting
                With Selection.Find
                    .Text = "ABC"
                    .MatchCase = True
                    .Replacement.Text = "XYZ"
                End With
                Selection.Find.Execute Replace:=wdReplaceAll


                ' save and close the current document
                ActiveDocument.Close wdSaveChanges
            Next i
        Else
            ' if the system cannot find any files
            ' with the .doc extension
            MsgBox "No files found."
        End If
    End With
End Sub
Milan SoniAsked:
Who is Participating?
 
Neil FlemingConnect With a Mentor Independent consultantCommented:
In fact, clearly your code does run from Word, not Excel -  apologies. So here is a Word version, which also does not require any changes to the VBA references library, because it creates the FileSystemObject on the fly, and defines all the FS variables just as Objects.


Sub changeAll()
'routine to call MassReplace with specific folder:
MassReplace "C:\Users\milans\Desktop\Procedure - Test"
End Sub

Public Sub MassReplace(sFolder As String)

'requires reference to Microsoft Scripting Runtime in Tools|References:
Dim fS As Object
Dim fFolder As Object, fSubfolder As Object, fFile As Object
Dim sExt As String

On Error GoTo errortrap
Set fS = CreateObject("Scripting.FileSystemObject")
Set fFolder = fS.GetFolder(sFolder)
    'loop through subfolders, running MassReplace on each of them
    For Each fSubfolder In fFolder.SubFolders
    MassReplace fSubfolder.Path
    Next

    'now check files in folder
    For Each fFile In fFolder.Files
    sExt = fS.GetExtensionName(fFile)
    'open .docx files that are not temp copies whose name begins with "~":
        If (sExt = "docx") And (Left(fFile.Name, 1) <> "~") Then
        Documents.Open FileName:=fFile.Path, ReadOnly:=False
        'perform changes to file HERE
        'then close file
        ActiveDocument.Close wdSaveChanges
        End If
    Next
 'dispose of the filesystemObject
Set fS = Nothing
Exit Sub
errortrap:
MsgBox ("An error has occurred")
          
End Sub

Open in new window

1
 
Neil FlemingIndependent consultantCommented:
The built-in Application.Filesearch ceased to exist with Office 2010. It looks as if you are using a custom Class module called "ApplicationFileSearch" (with no period) that tries to replicates the functionality.

Possibly the error is in the code for that class module.

However, it is also possible that your code is simply not detecting temporary files created by Word, that is files whose name begins with a tilde "~" eg
"~myfile.docx"

Open in new window

. Attempts to open these files will result in the error that you report. It may be by chance that such files only exist in your sub-folders. In any case you can try fixing this by re-writing your code to read:
 For i = 1 To .FoundFiles.Count
 ' open the file based on its index position
'check first letter of filename for "~"
If Left(.Foundfiles(i),1)<>"~" then 
Documents.Open FileName:=.FoundFiles(i), ReadOnly:=False
'etc etc.. perform the search and replace and then:
End If
'etc etc

Open in new window


However, you may be better off ditching your class module and re-writing the procedure to use Microsoft's FileSystemObject . Something like this code below, which I wrote assuming you are doing this from Excel (not sure why I thought that). If you are doing it from Word itself, then there is no need for the creation of the WordApp variable or the later reference to it. You can just use:
Documents.Open Filename:=fFile.Path, ReadOnly:=False

Open in new window

as in your original code.

Note that you would need to manually add references to the Word library and to Microsoft Scripting Runtime in the "Tools|References" menu in the VBA editor.

Sub changeAll()
'routine to call MassReplace with specific folder:
MassReplace "C:\Users\milans\Desktop\Procedure - Test"
End Sub

Public Sub MassReplace(sFolder As String)
'NB:requires reference to Microsoft Word in Tools|References:
Dim WordApp As Word.Application
'requires reference to Microsoft Scripting Runtime in Tools|References:
Dim fS As New FileSystemObject
Dim fFolder As Folder, fSubfolder As Folder, fFile As File
Dim sExt As String

On Error GoTo errortrap
'this assumes you have Word running, otherwise you will need additional code to open it if not
Set WordApp = GetObject(, "Word.Application")
Set fFolder = fS.GetFolder(sFolder)
    'loop through subfolders, running MassReplace on each of them
    For Each fSubfolder In fFolder.SubFolders
    MassReplace fSubfolder.Path
    Next

    'now check files in folder
    For Each fFile In fFolder.Files
    sExt = fS.GetExtensionName(fFile)
    'open .docx files that are not temp copies whose name begins with "~":
        If (sExt = "docx") And (Left(fFile.Name, 1) <> "~") Then
        WordApp.Documents.Open Filename:=fFile.Path, ReadOnly:=False
        'perform changes to file HERE
        'then close file
        WordApp.ActiveDocument.Close wdSaveChanges
        End If
    Next
 'dispose of the filesystemObject      
Set fS = Nothing
Exit Sub
errortrap:
MsgBox ("An error has occurred")
          
End Sub

Open in new window

0
 
Milan SoniAuthor Commented:
Thanks Neil. It really helped. I tweaked a little to add find and replace portion in code.
0
 
Neil FlemingIndependent consultantCommented:
My pleasure. Glad it worked.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.