How can i adapt below code to search through subfolders? Currently only searches within the folder i select via the dialog box.

Option Compare Database

 

Option Explicit

Sub SearchFoldersForContent()


Dim oWordapp As Word.Application

Dim oWorddoc As Word.Document

 

Set oWordapp = CreateObject("Word.Application")

oWordapp.Visible = True

 

Set oWorddoc = oWordapp.Documents.Add

 

Dim oRecordDoc As Word.Document, oSourceDoc As Word.Document

Dim bProtected As Boolean, lngProtType As Long

Dim oRng As Word.Range

Dim oDialog As FileDialog

 

Dim pFilename As String, pPath As String, pFind As String

Dim arrFind() As String

Dim i As Long, j As Long

 

 

'Pick folder containing files to search

 

Set oDialog = Application.FileDialog(msoFileDialogFolderPicker)

 

 

With oDialog

  .Title = "Select Folder Containing Files to Search"

  .AllowMultiSelect = False

  .InitialView = msoFileDialogViewList

 

 

 

  If .Show <> -1 Then

    MsgBox "You did not select a folder to process.", vbInformation + vbOKOnly, "PROCESS CANCELED"

    Exit Sub

  End If

  pPath = oDialog.SelectedItems.Item(1)

End With

If Right(pPath, 1) <> "\" Then pPath = pPath + "\"

 

 

'Get user defined search term/s

Do

  pFind = InputBox("Enter the word or text you want to find." & vbCr + vbCr _

                 & "To search for multiple terms separate each term with the pipe ""|"" character " & vbCr _

                 & "(e.g., Programmer|programmer|Software Developer", "SEARCH TERMS")

  pFind = RealInput(pFind)

  If pFind = "**Input canceled by user**" Then

    Exit Sub

  End If

Loop Until pFind <> ""

'Create the search array

arrFind = Split(pFind, "|")

'Develop informational text

pFind = ""

For i = 0 To UBound(arrFind)

  If i < UBound(arrFind) Then

    pFind = pFind & arrFind(i) & " - "

  Else

   pFind = pFind & arrFind(i)

  End If

Next i

 

Set oRecordDoc = ActiveDocument

 

'Set oRecordDoc = New Word.Application

 

'Set up report header, footer, heading text

With oRecordDoc

'With .Documents.Add

'End With

 

 

 

  With .Range

    .Text = "Results for Terms:  " & pFind & vbCr + vbCr

    .Paragraphs(1).SpaceBefore = 12

    .Paragraphs(1).SpaceAfter = 18

    .Paragraphs(1).Range.Font.Bold = True

  End With

    With .Sections(1).Headers(wdHeaderFooterPrimary).Range

    .Text = "Content Search Folder: " & pPath & vbCr & _

     "Creation date: " & Format(Date, "MMMM d, yyyy")

     With .ParagraphFormat.Borders(wdBorderBottom)

       .LineStyle = wdLineStyleSingle

       .LineWidth = wdLineWidth050pt

       .Color = wdColorAutomatic

     End With

     .ParagraphFormat.Borders.DistanceFromBottom = 3

  End With

  Set oRng = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range

  With oRng

    .Text = ""

    .InsertBefore "Content Report" & vbTab + vbTab

    'Working backwards

    .Collapse wdCollapseEnd

    .Fields.Add oRng, Type:=wdFieldEmpty, Text:="NUMPAGES \* Arabic "

    .Collapse wdCollapseStart

    .Text = " of "

    .Collapse wdCollapseStart

    .Fields.Add oRng, Type:=wdFieldEmpty, Text:="PAGE \* Arabic"

    With .ParagraphFormat.Borders(wdBorderTop)

       .LineStyle = wdLineStyleSingle

       .LineWidth = wdLineWidth050pt

       .Color = wdColorAutomatic

    End With

  End With

End With

'Process the files in the selected folder

pFilename = Dir$(pPath & "*.doc?")

WordBasic.DisableAutoMacros 1

While Len(pFilename) <> 0

  'Open the document for processing

  'Dim oSourceDoc As Word.Document

  Set oSourceDoc = Documents.Open(FileName:=pPath & pFilename, Visible:=False)

  'Determine protection status and unprotect if required

  bProtected = False

  If oSourceDoc.ProtectionType <> wdNoProtection Then

    bProtected = True

    lngProtType = oSourceDoc.ProtectionType

    oSourceDoc.Unprotect

  End If

  'Search for terms

  For i = 0 To UBound(arrFind)

    Set oRng = oSourceDoc.Range

    With oRng.Find

      .Execute FindText:=arrFind(i)

      'Process finding and terminate search

      If .Found Then

        j = j + 1

        oRecordDoc.Range.InsertAfter j & ".  " & pPath & pFilename & vbCr

        Exit For

      End If

    End With

  Next i

  If bProtected Then oSourceDoc.Protect lngProtType, True

  oSourceDoc.Close SaveChanges:=Word.wdDoNotSaveChanges

  'Get next file

  pFilename = Dir$()

Wend

WordBasic.DisableAutoMacros 0

oRecordDoc.Activate

'ActiveDocument.Range.InsertAfter vbCr & "Number of files found: " & j & vbCr

oRecordDoc.Range.InsertAfter vbCr & "Number of files found: " & j & vbCr

End Sub

Function RealInput(pInput As String) As String

If StrPtr(pInput) = 0 Then

  MsgBox "This process cannot be executed unless a search string is defined.", vbInformation + vbOKOnly, "CANCELING PROCESS"

  RealInput = "**Input canceled by user**"

Else

  If pInput = "" Then

    RealInput = ""

    MsgBox "You did not provide an input.", vbInformation + vbOKOnly, "NOTHING DEFINED"

  Else

    RealInput = pInput

  End If

End If

End Function

 

Private Sub Detail_Click()

Call SearchFoldersForContent

End Sub