02 February 2007

clsFSOSearch - VBA

Option Explicit

' a search class to go with the other FSO wrappers
'

Private col As VBA.Collection

' *****************************************************************************
Private Sub Class_Terminate()

Dim lngItem As Long

For lngItem = 1 To col.Count
col.Remove 1
Next lngItem

Set col = Nothing

End Sub

' *****************************************************************************
Private Sub Class_Initialize()
Set col = New VBA.Collection
End Sub

' *****************************************************************************
Public Function Item(Index As Variant) As clsFSOFile
Set Item = col.Item(Index)
End Function

' *****************************************************************************
Public Function Count() As Long
Count = col.Count
End Function

' ******************************************************************************
Public Function ClearResults() As clsFSOSearch
Call Class_Terminate
Call Class_Initialize

Set ClearResults = Me

End Function

' *****************************************************************************
Public Function Search(LookInFolder As String, _
SearchString As String, Optional ExclusionSearch As Boolean = False) _
As clsFSOSearch
' LookInFolder: Folder to search
' SearchString: Pattern to search for. Accepts '*' as wildcard
' ExclusionSearch: Excludes found files, add those that do not match

Dim strSearch() As String
Dim lngItem As Long

Dim objFile As clsFSOFile
Dim objFolder As clsFSOFolder

strSearch() = VBA.Split(SearchString, "*")
Set objFolder = New clsFSOFolder

With objFolder.Init(LookInFolder).Files

Select Case ExclusionSearch

Case False
For lngItem = 1 To .Count
Set objFile = .Item(lngItem)
If FitsPattern(strSearch(), objFile.name) Then
col.Add objFile, objFile.name
End If
Next lngItem

Case True
For lngItem = 1 To .Count
Set objFile = .Item(lngItem)
If Not FitsPattern(strSearch(), objFile.name) Then
col.Add objFile, objFile.name
End If
Next lngItem
End Select

End With

Set Search = Me
Set objFile = Nothing
Set objFolder = Nothing

End Function
' *****************************************************************************
Private Sub AddWithSearch(SearchString As String, File As clsFSOFile, _
FSOFiles As Object, FSOFile As Object)

Dim Search() As String

Search() = VBA.Split(SearchString, "*")

For Each FSOFile In FSOFiles
Set File = New clsFSOFile
If FitsPattern(Search(), File.Init(FSOFile.Path).name) Then
col.Add FSOFile
End If
Next FSOFile

End Sub

' *****************************************************************************
Private Function FitsPattern(SearchArray() As String, SearchedString As String) As Boolean
On Error GoTo err_handle

Dim lngSearchLen As Long ' length of the search string
Dim lngItemLen As Long ' length of the item in the array
Dim lngPos As Long ' search starting position
Dim lngLocation As Long ' location of the search string
Dim lngItem As Long ' array item
Dim UpperBound As Long, LowerBound As Long ' upper/lower bound of array
Dim blnSuccess As Boolean ' indicates success

lngSearchLen = VBA.Len(SearchedString) ' length of search string
lngPos = lngSearchLen ' initialize search position
UpperBound = UBound(SearchArray) ' upper bound of array
LowerBound = LBound(SearchArray) ' lower bound of array
blnSuccess = True ' initialize success to true

For lngItem = LowerBound To UpperBound
lngItemLen = VBA.Len(SearchArray(lngItem))
If lngItemLen Then

Select Case lngItem

Case (LowerBound + 1) To (UpperBound - 1)
' find the location of the search string from one of the patterns, starting from the last
' pattern search position
lngLocation = VBA.InStr(lngSearchLen - lngPos + 1, SearchedString, SearchArray(lngItem))
Select Case lngLocation

' if found, adjust the position forward
Case Is <> 0
lngPos = lngPos - lngLocation

Case Else ' not found or too late in the string
Err.Raise VBA.vbObjectError

End Select

Case LowerBound
' if lower bound of the array, then must start with the string
If VBA.Left$(SearchedString, lngItemLen) <> SearchArray(lngItem) Then _
Err.Raise VBA.vbObjectError

Case UpperBound
' position of previous search cannot be part of the last search
If (lngSearchLen - lngLocation) <>
Err.Raise VBA.vbObjectError
' if upper bound of the array, then must end with the search string
ElseIf VBA.Right$(SearchedString, lngItemLen) <> SearchArray(lngItem) Then
Err.Raise VBA.vbObjectError
End If

End Select

End If
Next lngItem

exit_err:
FitsPattern = blnSuccess

Exit Function
err_handle:

blnSuccess = False
Resume exit_err

End Function