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