Seach ''WORD'' in multiple doc/docx files (different folders!) at the same time

macropod · #1 05-26-2017, 12:14 AM

I have re-tested the code and it does not produce an error when modified as directed.

Abcde · #2 05-28-2017, 10:38 PM

Still getting error. Here is the code and i can only hope that after fixing this error (if I manage to), all the folders, including the ones from internal network will be visible on relevant location:

Code:

Sub Search()
'
' Search Macro
'Option Explicit
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Dim i As Long, strNm As String, strFnd As String, strFile As String, strList As String
 
Sub FindTextInDocs()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = Trim(InputBox("What is the Top Folder, "Get Top Folder"))
If StrFolder = "" Then Exit Sub
strFnd = InputBox("What is the string to find?", "File Finder")
If Trim(strFnd) = "" Then Exit Sub
strNm = ActiveDocument.FullName
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " files processed." & vbCr & "Matches with " & strFnd & " found in:" & strList, vbOKOnly
End Sub
 
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then Set FSO = CreateObject("scripting.filesystemobject")
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
 
Sub GetFolder(StrFolder As String)
strFile = Dir(StrFolder & "*.doc", vbNormal)
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  i = i + 1
  Call DocTest(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
 
Sub DocTest(strDoc As String)
Dim Doc As Document
' Open the document
If strDoc <> strNm Then
  Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=True, Format:=wdOpenFormatAuto, Visible:=False)
  With Doc
    With .Range
      With .Find
        .Text = strFnd
        .MatchCase = False
        .MatchAllWordForms = False
        .MatchWholeWord = False
        .Execute
        If .Found Then strList = strList & vbCr & strFile
      End With
    End With
    .Close SaveChanges:=False
  End With
End If
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub
End Sub

Abcde · #3 06-01-2017, 03:38 AM

In this message I am attaching the latest copy paste version of the code I use. This one should be a little better but there is still problem which is mentioned on the sceeenshot in this message before the attached code. Note that when I click on button ''debug'' the line which gets yellow background colored is the following one without the quotes: ".Execute" and I would also like to add the following information: The error message shown on screenshot occurs after around 20 minutes of searching time. BEFORE error occurs, I don't see any problem at all - entire searching procedure seems OK. Very long searching time is no problem and understandable because the macro is ''working with'' over 20 000 doc/docx files at the same time.

SCREENSHOT: http://imgur.com/a/60Hu5

Code:

Option Explicit
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Dim i As Long, strNm As String, strFnd As String, strFile As String, strList As String
 
Sub FindTextInDocs()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = Trim(InputBox("What is the Top Folder?", "Get Top Folder"))
If StrFolder = "" Then Exit Sub
strFnd = InputBox("What is the string to find?", "File Finder")
If Trim(strFnd) = "" Then Exit Sub
strNm = ActiveDocument.FullName
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " files processed." & vbCr & "Matches with " & strFnd & " found in:" & strList, vbOKOnly
End Sub
 
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then Set FSO = CreateObject("scripting.filesystemobject")
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
 
Sub GetFolder(StrFolder As String)
strFile = Dir(StrFolder & "*.doc", vbNormal)
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  i = i + 1
  Call DocTest(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
 
Sub DocTest(strDoc As String)
Dim Doc As Document
' Open the document
If strDoc <> strNm Then
  Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=True, Format:=wdOpenFormatAuto, Visible:=False)
  With Doc
    With .Range
      With .Find
        .Text = strFnd
        .MatchCase = False
        .MatchAllWordForms = False
        .MatchWholeWord = False
        .Execute
        If .Found Then strList = strList & vbCr & strFile
      End With
    End With
    .Close SaveChanges:=False
  End With
End If
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub

Abcde · #4 06-01-2017, 12:21 AM

I spent last 10 hours nonstop trying to solve this and no progress at all. This is exact copy paste of ENTIRE code I have and in the relevant line I showed in my previous post, I don't see any difference:

Code:

Sub Search()
'
' Search Macro
'Option Explicit
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Dim i As Long, strNm As String, strFnd As String, strFile As String, strList As String
 
Sub FindTextInDocs()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = Trim(InputBox("What is the Top Folder?", "Get Top Folder"))
If StrFolder = "" Then Exit Sub
strFnd = InputBox("What is the string to find?", "File Finder")
If Trim(strFnd) = "" Then Exit Sub
strNm = ActiveDocument.FullName
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " files processed." & vbCr & "Matches with " & strFnd & " found in:" & strList, vbOKOnly
End Sub
 
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then Set FSO = CreateObject("scripting.filesystemobject")
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
 
Sub GetFolder(StrFolder As String)
strFile = Dir(StrFolder & "*.doc", vbNormal)
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  i = i + 1
  Call DocTest(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
 
Sub DocTest(strDoc As String)
Dim Doc As Document
' Open the document
If strDoc <> strNm Then
  Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=True, Format:=wdOpenFormatAuto, Visible:=False)
  With Doc
    With .Range
      With .Find
        .Text = strFnd
        .MatchCase = False
        .MatchAllWordForms = False
        .MatchWholeWord = False
        .Execute
        If .Found Then strList = strList & vbCr & strFile
      End With
    End With
    .Close SaveChanges:=False
  End With
End If
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Run a macro on multiple docx. files	Peter Carter	Word VBA	27	12-15-2022 04:10 PM
Run Code on all files and save files as .docx	Plokimu77	Word VBA	4	06-05-2016 04:41 PM
seach an Excel list elements in word document	7ajar	Word VBA	5	03-16-2011 12:38 PM
Word 2010 not reading docx files	Dannyg	Word	1	09-22-2010 09:45 PM
Multiple editor at the same time with Word?	GaGaGa	Word	1	09-19-2010 02:24 AM