FSO Wrapper Classes - Comments

I wrote the FSO classes because I needed to have some late binding file capabilities but was tired of trying to guess all the method calls. There wasn't a requirement to implement all of the FSO functionality, so if you use these classes you may have to add a method or two for your own programming purposes.

Speed is an issue here for some larger file processing. If you need something speedy, I early-bind to the FSO objects or late bind directly in your code.

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

clsFSOFolders - VBA

Option Explicit

' a late binding wrapper class for FSO Folders collection object
'

Private objFolders As Object
Private strFolders() As String

Public Event FolderIndexed(FSOFolder As clsFSOFolder)

' *****************************************************************************
Private Sub Class_Terminate()
Set objFolders = Nothing
End Sub

' *****************************************************************************
Public Function Init(Folders As Object) As clsFSOFolders
Set objFolders = Folders
Set Init = Me
ReDim strFolders(0)
End Function

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

' *****************************************************************************
Public Function Item(Index As Long) As clsFSOFolder

Dim objFold As clsFSOFolder

Set objFold = New clsFSOFolder
Set Item = objFold.Init(strFolders(Index))
Set objFold = Nothing

End Function

' *****************************************************************************
Public Function Index() As clsFSOFolders

Dim objFolder As Object
Dim lngItem As Long

ReDim strFiles(1 To objFolders.Count)

lngItem = 1
For Each objFolder In objFolders
strFiles(lngItem) = objFolder.Path
RaiseEvent FolderIndexed(Me.Item(lngItem))
lngItem = lngItem + 1
Next objFolder

Set objFolder = Nothing
Set Index = Me

End Function

clsFSOFolder - VBA

Option Explicit

' a late binding wrapper class for FSO Folder object
'

Private objFold As Object
Private WithEvents objFiles As clsFSOFiles
Private WithEvents objFolders As clsFSOFolders

Private lngSize As Currency
Private lngFileCount As Long

Public Event FileIndexed(FSOFile As clsFSOFile)
Public Event FolderIndexed(FSOFolder As clsFSOFolder)

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

Set objFolders = Nothing
Set objFiles = Nothing
Set objFold = Nothing

End Sub

' *****************************************************************************
Public Function Init(FolderPath As String) As clsFSOFolder
On Error GoTo err_handle

Dim objFSO As Object

Set objFSO = VBA.CreateObject("Scripting.FileSystemObject")
Set objFold = objFSO.GetFolder(VBA.Trim$(FolderPath))
Set objFSO = Nothing
Me.Changed

exit_err:
Set Init = Me

Exit Function

err_handle:
Set objFold = Nothing
Resume exit_err

End Function

' *****************************************************************************
Public Function Create(FolderPath As String, _
Optional RecursiveAttempts As Integer = 100) As clsFSOFolder
' creates the file if it doesn't already exist

Dim strParent As String

Select Case Me.Init(FolderPath).Exists Or (RecursiveAttempts = 0)

' path doesn't exist - attempt to create the parent directory
Case False
' strip off final slash
If VBA.Right$(FolderPath, 1) = "\" Then FolderPath = VBA.Left$(FolderPath, VBA.Len(FolderPath) - 1)
' get the parent directory
strParent = VBA.Left$(FolderPath, VBA.InStrRev(FolderPath, "\"))

' does the parent directory exist?
Select Case Me.Init(strParent).Exists

' create a new FSO and create the directory
Case True
Set Create = FSOCreate(FolderPath)

' recursively call create to create the parent
Case False
Me.Create strParent, RecursiveAttempts - 1
Set Create = FSOCreate(FolderPath)

End Select

' path exists - return reference to FSO Object
Case True
Set Create = Me

End Select

End Function
' *****************************************************************************
Private Function FSOCreate(FolderPath As String) As clsFSOFolder
On Error Resume Next

Dim objFSO As Object

Set objFSO = VBA.CreateObject("Scripting.FileSystemObject")
objFSO.CreateFolder FolderPath
Set objFSO = Nothing
Set FSOCreate = Me.Init(FolderPath)

End Function

' *****************************************************************************
Public Function DateCreated() As Date
DateCreated = objFold.DateCreated
End Function

' *****************************************************************************
Public Function Path() As String

Const acSLASH As String = "\"

Dim strReturn As String

strReturn = objFold.Path
Select Case VBA.Right$(strReturn, 1)
Case Is <> acSLASH
Path = strReturn & acSLASH
Case Else
Path = strReturn
End Select

End Function

' *****************************************************************************
Public Function DateLastAccessed() As Date
DateLastAccessed = objFold.DateLastAccessed
End Function

' *****************************************************************************
Public Function DateLastModified() As Date
DateLastModified = objFold.DateLastModified
End Function

' *****************************************************************************
Public Function name() As String
name = objFold.name
End Function

' *****************************************************************************
Public Function ParentFolder() As clsFSOFolder

Dim objFolder As clsFSOFolder
Set objFolder = New clsFSOFolder
Set ParentFolder = objFolder.Init(objFold.ParentFolder)
Set objFolder = Nothing

End Function

' *****************************************************************************
Public Function Size() As Currency
Size = objFold.Size
End Function

' *****************************************************************************
Public Function FolderType() As String
FolderType = objFold.FolderType
End Function

' *****************************************************************************
Public Function SubFolders() As clsFSOFolders

Select Case objFolders Is Nothing

Case False
Set SubFolders = objFolders

Case True
Set objFolders = New clsFSOFolders
Set SubFolders = objFolders.Init(objFold.SubFolders)

End Select

End Function

' *****************************************************************************
Public Function Files() As clsFSOFiles

Select Case objFiles Is Nothing

Case False
Set Files = objFiles

Case True
Set objFiles = New clsFSOFiles
Set Files = objFiles.Init(objFold.Files)

End Select

End Function

' *****************************************************************************
Public Function Move(Destination As String) As Boolean
On Error GoTo err_handle

objFold.Move Destination
Move = True

exit_err:

Exit Function

err_handle:
Move = False
Resume exit_err

End Function

' *****************************************************************************
Public Function Changed() As Boolean
' indicates if the contents of the folder have changed

Changed = (objFold.Files.Count <> lngFileCount) Or _
(Me.Size <> lngSize)

lngSize = Me.Size
lngFileCount = objFold.Files.Count

End Function

' *****************************************************************************
Public Function Exists() As Boolean

Exists = Not objFold Is Nothing

End Function

' *****************************************************************************
Private Sub objFiles_FileIndexed(FSOFile As clsFSOFile)

RaiseEvent FileIndexed(FSOFile)

End Sub

' *****************************************************************************
Private Sub objFolders_FolderIndexed(FSOFolder As clsFSOFolder)

RaiseEvent FolderIndexed(FSOFolder)

End Sub

clsFSOFiles - VBA

Option Explicit

' a late binding wrapper class for FSO Files Collection
'

Private blnIndex As Boolean

Private objFSO As Object
Private col As VBA.Collection

Public Event FileIndexed(FSOFile As clsFSOFile)

' *****************************************************************************
Private Sub Class_Terminate()
Set col = Nothing
Set objFSO = Nothing
End Sub

' *****************************************************************************
Public Function Init(Files As Object) As clsFSOFiles
Set objFSO = Files
Set Init = Me
blnIndex = True
End Function

' *****************************************************************************
Public Function Count() As Long

If blnIndex Then Me.Index
Count = col.Count

End Function

' *****************************************************************************
Public Function Item(Index As Long) As clsFSOFile

If blnIndex Then Me.Index
Set Item = col.Item(Index)

End Function

' *****************************************************************************
Public Function Index() As clsFSOFiles

Dim objFile As Object
Dim objFSOFile As clsFSOFile

blnIndex = False
Set col = New VBA.Collection

For Each objFile In objFSO
Set objFSOFile = New clsFSOFile
col.Add objFSOFile.Init(objFile.Path)
RaiseEvent FileIndexed(objFSOFile)
Next objFile

Set objFile = Nothing
Set objFSOFile = Nothing

Set Index = Me

End Function

clsFSOFile - VBA

Option Explicit

' a late binding wrapper class for FSO Files
'

Private objFile As Object

' *****************************************************************************
Private Sub Class_Terminate()
Set objFile = Nothing
End Sub

' *****************************************************************************
Public Function Init(FilePath As String) As clsFSOFile
On Error GoTo err_handle

Dim objFSO As Object

Set objFSO = VBA.CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(FilePath)
Set objFSO = Nothing

exit_err:
Set Init = Me

Exit Function
err_handle:
Set objFile = Nothing
Resume exit_err

End Function
' *****************************************************************************
Public Function DateLastModified() As Date
DateLastModified = objFile.DateLastModified
End Function

' *****************************************************************************
Public Function DateCreated() As Date
DateCreated = objFile.DateCreated
End Function

' *****************************************************************************
Public Function Path() As String
Path = objFile.Path
End Function

' *****************************************************************************
Public Function DateLastAccessed() As Date
DateLastAccessed = objFile.DateLastAccessed
End Function

' *****************************************************************************
Public Function name() As String
name = objFile.name
End Function

' *****************************************************************************
Public Function ParentFolder() As clsFSOFolder

Dim objFolder As clsFSOFolder
Set objFolder = New clsFSOFolder
Set ParentFolder = objFolder.Init(objFile.ParentFolder)
Set objFolder = Nothing

End Function

' *****************************************************************************
Public Function Size() As Long
Size = objFile.Size
End Function

' *****************************************************************************
Public Function FileType() As String
FileType = objFile.Type
End Function

' *****************************************************************************
Public Function Move(Destination As String, _
Optional Overwrite As Boolean = True) As Boolean
On Error GoTo err_handle

If VBA.Right$(Destination, 1) <> "\" Then Destination = Destination & "\"

objFile.Move Destination & Me.name
Move = True
exit_err:

Exit Function

err_handle:
Select Case Err.Number
Case 58 ' enmError.errFileExists
If Overwrite Then
objFile.Copy Destination, Overwrite
objFile.Delete
End If
Case Else
Move = False
End Select

Resume exit_err
End Function

' *****************************************************************************
Public Function Extension() As String

Dim strName As String
Dim lngPos As Long

strName = Me.name
lngPos = VBA.InStrRev(strName, ".")
Select Case lngPos
Case Is > 0
Extension = VBA.LCase$(VBA.Mid$(strName, lngPos + 1, VBA.Len(strName)))
Case Else
Extension = VBA.vbNullString
End Select

End Function

' *****************************************************************************
Public Function Exists() As Boolean
Exists = Not (objFile Is Nothing)
End Function

' *****************************************************************************
Public Function Delete() As Boolean
' returns true if successful, false if not. this method will not return
' any errors if the file does not exist
On Error Resume Next

objFile.Delete
Delete = Not VBA.CBool(Err.Number)
Err.Clear
Set objFile = Nothing

End Function