Option Explicit
Public Event FindFilesCurrentDir(ByVal CurrentDirectory As String)
Public Event FindFilesFound(ByVal Path As String, ByVal FileName As String, ByVal FirstSearchWordFound As String)
Public Event FindFilesDone(ByRef ReturnList As Collection)
Public Event FindFilesCancel(ByRef CancelFind As Boolean)
Public Sub FindStrInDir(ByRef ReturnList As Collection, ByVal Root As String, ByVal Recurse As Boolean, _
ByVal FileTypes As String, ByVal StrFileSize As String, ByVal Attributes As VbFileAttribute, _
ByVal Compare As VbCompareMethod, ParamArray StrToFind() As Variant)
Dim LOSize As Long, HISize As Long, K As Long
Dim FTypes() As String, SFindCol As New Collection, SFind() As String
FTypes = Split(FileTypes, ";") ' file types are delimited by ";", example "*.txt;*test*.dat;*.html;*blah blah*.htm"
FlattenParamArrayToString SFindCol, StrToFind
If SFindCol.Count > 0 Then
ReDim SFind(SFindCol.Count - 1)
For K = 0 To UBound(SFind)
SFind(K) = SFindCol(1)
SFindCol.Remove 1
Next K
Else
ReDim SFind(0)
End If
If Attributes = 0 Then Attributes = vbDirectory + vbReadOnly + vbSystem + vbArchive + vbHidden
'If Compare = 0 Then Compare = vbBinaryCompare ' vbBinaryCompare IS 0 ...
' Get Low and High boundries for the file size to find
If Len(StrFileSize) = 0 Then
LOSize = 0
HISize = 0
Else
K = InStr(1, StrFileSize, "-")
If K > 0 Then
LOSize = Val(Left(StrFileSize, K - 1))
HISize = Val(Mid(StrFileSize, K + 1))
Else
LOSize = 0
HISize = Val(StrFileSize)
End If
End If
' replace "/" with "\" (just in case)
If InStr(1, Root, "/") > 0 Then Root = Replace(Root, "/", "\")
' if recurse, list directories also
If Recurse Then Attributes = Attributes Or vbDirectory
FindStrInDirRecurse ReturnList, Root, Recurse, FTypes, LOSize, HISize, Attributes, Compare, SFind
RaiseEvent FindFilesDone(ReturnList)
End Sub
Private Sub FlattenParamArrayToString(RetList As Collection, ParamArray Arr() As Variant)
Dim K As Long, Q As Long, Str() As String, StrVal As String
On Error Resume Next
For K = LBound(Arr(0)) To UBound(Arr(0))
If (VarType(Arr(0)(K)) And vbArray) = vbArray Then
For Q = LBound(Arr(0)(K)) To UBound(Arr(0)(K))
If (VarType(Arr(0)(K)(Q)) And vbArray) = vbArray Then
FlattenParamArrayToString RetList, Arr(0)(K)(Q)
Else
StrVal = CStr(Arr(0)(K)(Q))
If Err.Number <> 0 Then
Err.Clear
Else
If Len(Trim(StrVal)) > 0 Then RetList.Add StrVal
End If
End If
Next Q
Else
StrVal = CStr(Arr(0)(K))
If Err.Number <> 0 Then
Err.Clear
Else
If Len(Trim(StrVal)) > 0 Then RetList.Add StrVal
End If
End If
Next K
End Sub
Private Function FindStrInDirRecurse(ByRef ReturnList As Collection, ByVal Root As String, ByVal Recurse As Boolean, _
FileTypes() As String, ByVal LOSize As Long, ByVal HISize As Long, ByVal Attributes As VbFileAttribute, _
Compare As VbCompareMethod, StrToFind() As String) As Boolean
Dim DirX As String, K As Long, Dirs As New Collection, FF As Integer, FileData As String
Dim FileSize As Long, CancelFind As Boolean
' make sure we have "\" at the end of directory
If Right(Root, 1) <> "\" Then Root = Root & "\"
On Error GoTo ExitFunction
' find first file, if error here, just exit function
DirX = Dir(Root & "*.*", Attributes)
RaiseEvent FindFilesCurrentDir(Root)
' loop until nothing is found
Do Until Len(DirX) = 0
If DirX <> "." And DirX <> ".." Then
On Error Resume Next ' I tried with "On Error GoTo ..." but it does not work for some reason for file "pagefile.sys"
If (GetAttr(Root & DirX) And vbDirectory) = vbDirectory Then ' if directory, add it to our list
If Err.Number <> 0 Then GoTo NextFile
If Recurse Then Dirs.Add DirX
Else
On Error GoTo NextFile
FileSize = FileLen(Root & DirX)
' check file size
If (LOSize = 0 And HISize = 0) Or (FileSize >= LOSize And FileSize <= HISize And FileSize > 0) Then
' check file type
For K = 0 To UBound(FileTypes)
If DirX Like FileTypes(K) Then Exit For
Next K
If K <= UBound(FileTypes) Then
If UBound(StrToFind) = 0 And Len(StrToFind(0)) = 0 Then
K = 0 ' don't search in file (search string array is empty)
Else
FF = FreeFile
' get file data
Open Root & DirX For Binary Access Read As FF
FileData = String(LOF(FF), 0)
Get FF, , FileData
Close FF
' find string(s) in the file
For K = 0 To UBound(StrToFind)
If InStr(1, FileData, StrToFind(K), Compare) > 0 Then Exit For
Next K
End If
' if passed ALL the tests, and the file to return list
If K <= UBound(StrToFind) Then
ReturnList.Add Root & DirX
RaiseEvent FindFilesFound(Root, DirX, StrToFind(K))
End If
End If
End If
End If
End If
NextFile: ' for some system files like "hiberfil.sys" or "pagefile.sys" it will return error when you try to access it
If Err.Number <> 0 Then Err.Number = 0
RaiseEvent FindFilesCancel(CancelFind)
If CancelFind Then
FindStrInDirRecurse = False
Exit Function
End If
DirX = Dir
Loop
On Error GoTo 0
If Recurse Then
Do While Dirs.Count > 0
' recurse through all dirs found in this directory
If FindStrInDirRecurse(ReturnList, Root & Dirs(1), True, FileTypes, LOSize, HISize, Attributes, Compare, StrToFind) Then
Dirs.Remove 1
Else
FindStrInDirRecurse = False
Exit Function
End If
Loop
End If
ExitFunction:
FindStrInDirRecurse = True
End Function
