Dim dictExtensions As Scripting.Dictionary
Dim WsFiles As Worksheet
Private Sub subMain()
Dim diaFolderPicker As FileDialog
Dim strFolder As String
Dim strKeywords As String
Dim s As String
Dim arr() As Variant
Dim intCount As Integer
Dim intOccurrences As Integer
On Error GoTo Err_Handler
ActiveWorkbook.Save
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Files"
Set WsFiles = Worksheets("Files")
WsFiles.Cells.ClearContents
WsFiles.Range("A1").Resize(1, 9).Value = Array("Location", "Name", "File Created Date", _
"File Created Time", "Size", "Type", "Keyword Number", "Keyword", "Keyword Hits")
Set dictExtensions = New Scripting.Dictionary
dictExtensions.Add key:="txt", Item:=dictExtensions.Count + 1
' Prompt for folder.
Set diaFolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With diaFolderPicker
.Title = "Select A Base Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
strFolder = .SelectedItems(1)
End With
' Prompt for keywords.
strKeywords = InputBox("Enter keywords seperated by a comma.")
If strKeywords = "" Then
Exit Sub
End If
Call subLoopThroughFiles(strFolder, strKeywords)
WsFiles.Range("C:C").NumberFormat = "dd/mm/yyyy"
WsFiles.Range("D:D").NumberFormat = "hh:mm:ss"
WsFiles.Range("E:E").NumberFormat = "0"
With WsFiles.Range("A1").CurrentRegion
.Font.Size = 16
.RowHeight = 30
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlLeft
.IndentLevel = 1
With .Rows(1)
.Interior.Color = RGB(213, 213, 213)
.Font.Bold = True
End With
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = vbBlack
End With
.Cells.EntireColumn.AutoFit
End With
With WsFiles
With .Range("A2", .Cells(Rows.Count, "B").End(xlUp))
arr = .Worksheet.Evaluate("UNIQUE(" & .Address & ")")
intCount = UBound(arr)
End With
intOccurrences = WorksheetFunction.Sum(.Range("I2", .Cells(Rows.Count, "I").End(xlUp)))
End With
MsgBox intCount & " files contain " & intOccurrences & " occurrences of the keywords " & vbCrLf & vbCrLf & _
strKeywords & ".", vbOKCancel, "Confirmation"
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "There has been an error. " & vbCrLf & vbCrLf & Err.Number & " " & Err.Description
Resume Exit_Handler
End Sub
Private Function fncCount_String(ByVal strSearch As String, _
ByVal strMatch As String, _
Optional blnCaseSensitive As Boolean = False, _
Optional blnAddWhiteSpace As Boolean = False) As Long
Dim i As Long
If blnAddWhiteSpace And Len(strMatch) > 1 Then
For i = Len(strMatch) - 1 To 1 Step -1
strMatch = Left$(strMatch, i) & "\s*" & Mid$(strMatch, i + 1)
Next i
End If
With CreateObject("vbscript.regexp")
.ignorecase = Not blnCaseSensitive
.Global = True
.Pattern = strMatch
fncCount_String = .Execute(strSearch).Count
End With
End Function
Private Sub subLoopThroughFiles(strFolder As String, strKeywords As String)
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFile As File
Dim objFolder As folder
Dim objSubFolder As folder
Dim i As Integer
Dim a As Integer
Dim arrKeywords() As String
Dim intCount As Integer
Dim lngCountThisFile As Long
Dim strFileText As String
On Error GoTo Err_Handler
If InStr(1, strKeywords, ",", vbTextCompare) = 0 Then
strKeywords = strKeywords & ","
End If
arrKeywords = Split(strKeywords, ",")
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
Call subLoopThroughFiles(strFolder & "\" & objSubFolder.Name, strKeywords)
For Each objFile In objSubFolder.Files
With objFile
If dictExtensions.Exists(objFSO.GetExtensionName(.Path)) Then
For i = LBound(arrKeywords) To UBound(arrKeywords)
strFileText = CreateObject("scripting.filesystemobject").OpenTextFile(.Path).ReadAll
intCount = fncCount_String(strFileText, arrKeywords(i), False, True)
If intCount > 0 Then
WsFiles.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1, 9).Value = Array(.ParentFolder, .Name, _
Format(.DateCreated, "dd/mm/yyyy"), Format(.DateCreated, "hh:mm:ss"), .Size, .Type, i + 1, arrKeywords(i), intCount)
End If
Next i '
End If ' Extension in the list.
End With ' objFile
Next objFile
Next objSubFolder
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "There has been an error. " & vbCrLf & vbCrLf & Err.Number & " " & Err.Description
Resume Exit_Handler
End Sub
