FileSystemObject encapsulation...

[Frosty]

I thought I would expose the fruits of my labors for anyone interested in the FileSystemObject. I post the code here for two purposes:
1) any advanced programmers who wouldn't mind taking a crack and breaking it (much appreciated extra set of eyes, for anyone with some time to kill);
2) any less experienced programmers who simply want to be able to copy some code, paste it into their project, and be able to see if a file is read-only, or be able to go through a loop of all files in a folder (and the sub folders).

Here are a couple of procedures which would demonstrate the use of this class.

NOTE: in order to have it work the way it is designed (with a default property), you would need to copy the clsFSO code (in three parts), paste into a single class module in your project, rename that class to clsFSO, and then export that class. Then you need to open the exported class in Notepad, and add the text "Attribute Path.VBUserMemID = 0" (without quotes) underneath the Public Property Get Path (), as indicated in the comments of that procedure.

My demonstration of the code assumes you have not set up the default property.
Demo code for a regular module:

Sub Demo_IterateThroughAllFilesAndFolders()
Dim oMyFSO As New clsFSO
Dim oFile As Object
Dim oFolder As Object

oMyFSO.Path = "C:\Temp"
'if you set up the default property, you could use this line...
'oMyFSO = "C:\Temp"

If oMyFSO.Exists Then
For Each oFile In oMyFSO.FilesAll
Debug.Print oFile.Path
Next

For Each oFolder In oMyFSO.SubFoldersAll
Debug.Print oFolder.Path
Next
Else
Debug.Print oMyFSO.Path & " doesn't exist!"
End If

End Sub
Sub Demo_GetSomeInfoAboutAFile()
Dim oMyFSO As New clsFSO

oMyFSO.Path = "C:\Temp\Test1.txt"
'if you set up the default property, you could use this line...
'oMyFSO = "C:\Temp\Test1.txt"

If oMyFSO.Exists Then
Debug.Print oMyFSO.Path & " readonly:=" & oMyFSO.ReadOnly
Debug.Print oMyFSO.Path & " FileSize in kilobytes:=" & oMyFSO.SizeKB

Else
Debug.Print oMyFSO.Path & " doesn't exist!"
End If

End Sub


Thanks in advance for any comments

[Frosty]

Hmm, it seems the class code is too long to be displayed, so I will break it into a couple of parts... NOTE: the following posts will need to be copied and put into a single class.

clsFSO (part 1 of code)

Option Explicit
'-----------------------------------------------------------------------------------------------
' MODULE: clsFSO
' PROGRAMMED BY: Jason Simpson
' PURPOSE: an easier way of dealing with FileSystemObject properties and methods
' encapsulates primary FSO methods and properties, as well as two added properties
' (.FilesAll and .SubFoldersAll) which use a recusive method to be able to iterate
' through all files or subfolders via a single collection
'
' DEFAULT PROPERTY: .Path
'
' USAGE: In any procedure in this project, dim the object as new, and set it equal to a path
' Dim oMyFSO As New clsFSO
' oMyFSO = "C:\MyPath" (or oMyFSO.Path = "C:\MyPath")
' OR
' oMyFSO = "C:\MyPath\MyFile.txt" (or oMyFSO.Path = "C:\MyPath\MyFile.txt"
'
' NOTES: Uses the sccrun.dll via CreateObject.
' Can also add a reference to the Microsoft Scripting Runtime library for early binding
'
' Check out http://msdn.microsoft.com/en-us/library/yb3tbdkw%28v=VS.85%29.aspx for more info
'-----------------------------------------------------------------------------------------------

'whether to display message boxes in the errors in our class module
Private Const CLASS_DEBUG As Boolean = True
Private Const CLASS_NAME As String = "clsFSO"

'primary holder for the file system object
Private m_oFSO As Object
'holder for the folder object, if appropriate
Private m_oFolder As Object
'holder for the file object, if appropriate
Private m_oFile As Object
'set to be either the File or Folder object
Private m_oMain As Object
'the path to our object, whether it exists or not
Private m_Path As String

'private collections for .FilesAll and .SubFoldersAll collections
Private m_colFilesAll As Collection
Private m_colSubFoldersAll As Collection

'-----------------------------------------------------------------------------------------------
' Get the File Size or Folder Size in KB
'-----------------------------------------------------------------------------------------------
Public Property Get SizeKB() As Single
If Me.Exists Then
SizeKB = m_oMain.Size / 1024
End If
End Property
'-----------------------------------------------------------------------------------------------
' Get the File Size or Folder Size in MB
'-----------------------------------------------------------------------------------------------
Public Property Get SizeMB() As Single
If Me.Exists Then
SizeMB = m_oMain.Size / 1024 / 1024
End If
End Property
'-----------------------------------------------------------------------------------------------
' A slightly easier way of toggling the read-only attribute
'-----------------------------------------------------------------------------------------------
Public Property Get ReadOnly() As Boolean
On Error GoTo l_err
If m_oMain.Attributes And vbReadOnly Then
ReadOnly = True
Else
ReadOnly = False
End If
l_exit:
Exit Property
l_err:
ReadOnly = False
Resume l_exit
End Property
Public Property Let ReadOnly(bReadOnly As Boolean)
Dim bIsReadOnly As Boolean

On Error GoTo l_err
'see what it currently is
If m_oMain.Attributes And vbReadOnly Then
bIsReadOnly = True
End If

'Toggle to a different state, if what we want and what exists is different
If bIsReadOnly <> bReadOnly Then
m_oMain.Attributes = m_oMain.Attributes Xor vbReadOnly
End If
l_exit:
Exit Property
l_err:
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' Publically accessible way of copying the file or folder
' Returns TRUE if successful
' Default to overwriting any existing files or folders
'-----------------------------------------------------------------------------------------------
Public Function Copy(ToWhere As String, Optional bOverwrite As Boolean = True) As Boolean
On Error GoTo l_err

'use different FileSystem methods, depending on what is suppposed to be copied
If Me.IsFile Then
m_oFSO.CopyFile m_Path, ToWhere, bOverwrite
ElseIf Me.IsFolder Then
m_oFSO.CopyFolder m_Path, ToWhere, bOverwrite
End If
'if no errors, return success
Copy = True
l_exit:
Exit Function

l_err:
'handle any errors
Select Case Err.Number
'file not found, return a known error
Case 53
MsgBox "File Not Found: " & m_Path, vbCritical, "Unable to copy..."

Case 58, 70
'58 = File already exists (or were told not to overwrite)
'70 = permission denied
'return false

'Path not found-- so attempt to create just the folder and retry
Case 76
'if we successfully create the folder, then attempt again
If CreateFolder(fGetPathFromString(ToWhere), False) Then
Resume
Else
MsgBox "Path not found: " & ToWhere, vbCritical, "Unable to copy..."
End If

'unanticipated errors, display or don't, depending on class debug mode
Case Else
If CLASS_DEBUG Then
MsgBox "Unknown error in " & CLASS_NAME & "::" & _
"Copy", vbCritical, "Error!"
End If
End Select
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' Publically accessible way of Moving a file or folder/subfolders
' Returns TRUE if successful
' NOTE: .Move, .MoveFile and .MoveFolder are all acceptable methods for the FSO.
' The primary difference is that .Move doesn't support Wildcard operators
' Further details at: http://msdn.microsoft.com/en-us/library/kxtftw67(v=vs.84).aspx
'-----------------------------------------------------------------------------------------------
Public Function Move(ToWhere As String) As Boolean
On Error GoTo l_err

'can only move things that exist
If Me.Exists Then
m_oMain.Move ToWhere
'and update our class
Me.Path = m_oMain.Path
End If

' Later development potential: adding wildcard functionality to use the individual methods
' 'use different FileSystem methods, depending on what is supposed to be moved
' If Me.IsFile Then
' m_oFSO.MoveFile m_oFile.Path, ToWhere
' ElseIf Me.IsFolder Then
' m_oFSO.MoveFolder m_oFolder.Name, ToWhere
' End If

'if no errors, return success
Move = True
l_exit:
Exit Function

l_err:
'handle any errors
Select Case Err.Number
'Path not found
Case 76
'attempt to create the desired containing folder
If CreateFolder(fGetPathFromString(ToWhere), False) Then
Resume
Else
MsgBox "Path not found: " & ToWhere, vbCritical, "Unable to move..."
End If

Case Else
If CLASS_DEBUG Then
MsgBox "Unknown error in " & CLASS_NAME & "::" & _
"Move", vbCritical, "Error!"
End If
End Select
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' A single Creation routine to encapsulate the FSO CreateTextFile and CreateFolder functionality
' optional to overwrite an existing item
'-----------------------------------------------------------------------------------------------
Public Function Create(Optional sFullName As String) As Boolean

On Error GoTo l_err
'set the path
If sFullName = "" Then
sFullName = Me.Path
Else
Me.Path = sFullName
End If

'if whatever we want to create doesn't already exist...
If Me.Exists = False Then
'create the appropriate thing
If Me.IsFile Then
Create = CreateTextFile(sFullName)
ElseIf Me.IsFolder Then
Create = CreateFolder(sFullName)
End If
End If
l_exit:
Exit Function

l_err:
Select Case Err.Number
Case Else
If CLASS_DEBUG Then
MsgBox "Unknown error in " & CLASS_NAME & "::" & _
"Move", vbCritical, "Error!"
End If
End Select
End Function

[Frosty]

Part 2

'-----------------------------------------------------------------------------------------------
' Create a text file from the passed string (if nothing passed, uses the existing path)
' Returns TRUE if successful
' Made PRIVATE to simplify creation using the custom .Create method
'-----------------------------------------------------------------------------------------------
Private Function CreateTextFile(Optional sNewFileName As String) As Boolean
On Error GoTo l_err
'set the path
If sNewFileName = "" Then
sNewFileName = Me.Path
Else
Me.Path = sNewFileName
End If
'if it doesn't already exist... then
If Me.Exists = False Then
m_oFSO.CreateTextFile sNewFileName
'only return true if the file didn't already exist
CreateTextFile = True
'update our class object with the newly created object's info
Me.Path = m_Path
End If

l_exit:
Exit Function

l_err:
Select Case Err.Number
'path not found error
Case 76
'attempt to create the containing folder and resume file creation
If CreateFolder(Me.PathOnly, False) Then
Resume
End If

'unknown issues
Case Else
'report unknown issues
If CLASS_DEBUG Then
MsgBox "Unknown error in " & CLASS_NAME & "::" & _
"CreateTextFile", vbCritical, "Error!"
End If
End Select
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' Create a folder from the passed string
' Returns TRUE if successful
' Made PRIVATE to simplify creation using the custom .Create method
' By default, it updates the class to represent the folder created
'-----------------------------------------------------------------------------------------------
Private Function CreateFolder(Optional sNewFolderName As String, _
Optional bUpdateClass As Boolean = True) As Boolean
Dim aryFolders() As String
Dim sRebuildFolder As String
Dim i As Integer
Dim oFolder As Object
Dim sOrigPath As String

On Error GoTo l_err
'set the path
If sNewFolderName = "" Then
sNewFolderName = Me.Path
Else
'if we're not going to update the class, then we need to store the original value
If bUpdateClass = False Then
sOrigPath = Me.Path
End If
'update our path info, so we can use .Exists below
Me.Path = sNewFolderName
End If

'if the folder structure doesn't already exist, then create all of the folders
'that don't exist already
If Me.Exists = False Then
'get an array of the folders to create, split on the path separator
aryFolders = VBA.Split(sNewFolderName, "\")

For i = 0 To UBound(aryFolders)
sRebuildFolder = sRebuildFolder & aryFolders(i) & "\"
'ignore any errors in creation (since those folders will already be there)
On Error Resume Next
m_oFSO.CreateFolder sRebuildFolder
On Error GoTo l_err
Next

CreateFolder = True
'update our class info, if desired
If bUpdateClass Then
Me.Path = m_Path
Else
Me.Path = sOrigPath
End If
End If
l_exit:
Exit Function

l_err:
Select Case Err.Number

Case Else
If CLASS_DEBUG Then
MsgBox "Unknown error in " & CLASS_NAME & "::" & _
"CreateFolder", vbCritical, "Error!"
End If
End Select
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' Publically accessible way of deleting the object (file or folder)
' Returns TRUE if successful
'-----------------------------------------------------------------------------------------------
Public Function Delete() As Boolean
On Error GoTo l_err
If Me.IsFile Then
'On Error Resume Next
m_oFSO.DeleteFile Me.Path
Delete = True
ElseIf Me.IsFolder Then
'On Error Resume Next
m_oFSO.DeleteFolder Me.Path
Delete = True
Else
'raise an error?
End If
'Update our class object
Me.Path = m_Path
l_exit:
Exit Function

l_err:
'handle errors
Select Case Err.Number
'File Not Found (53), Path Not Found (76), do nothing
Case 53, 76

'unknown error, report if we're in debug mode
Case Else
If CLASS_DEBUG Then
MsgBox "Unknown error in " & CLASS_NAME & "::" & _
"Delete", vbCritical, "Error!"
End If
End Select
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' publically exposed version of the object, whether it is a folder or file object
'-----------------------------------------------------------------------------------------------
Public Property Get Main() As Object
Set Main = m_oMain
End Property
'-----------------------------------------------------------------------------------------------
' pass in a path, attempt to validate it and update our class
' NOTE: this is the main operator of the class-- change here triggers changes elsewhere
'-----------------------------------------------------------------------------------------------
Public Property Let Path(sPath As String)
Set m_oFolder = Nothing
Set m_oFile = Nothing
Set m_oMain = Nothing

On Error Resume Next
'let's see what works -- try using GetFolder
Set m_oFolder = m_oFSO.GetFolder(sPath)
'if it wasn't a folder, then...
If m_oFolder Is Nothing Then
'try using GetFile
Set m_oFile = m_oFSO.GetFile(sPath)
'and set our main object appropriately
Set m_oMain = m_oFile
Else
'set our main object appropriately
Set m_oMain = m_oFolder
End If
'if we're unable to set m_oMain, then use the passed parameter
If m_oMain Is Nothing Then
'but truncate off any last "\" character, if it was passed
If VBA.Right(sPath, 1) = "\" Then
m_Path = VBA.Left(sPath, VBA.Len(sPath) - 1)
Else
m_Path = sPath
End If
'and clear our our custom collections
Set m_colSubFoldersAll = New Collection
Set m_colFilesAll = New Collection

'otherwise, use the actual object
Else
m_Path = m_oMain.Path
End If
'if our folder object is nothing, clear out our collection
If m_oFolder Is Nothing Then
Set m_colSubFoldersAll = Nothing
Set m_colFilesAll = Nothing
'otherwise, repopulate our custom collections of all files and all subfolders
Else
Set m_colSubFoldersAll = fGetAllSubFolders(m_oFolder)
Set m_colFilesAll = fGetAllFiles
End If
'clear out the error, since On Error Resume Next can create a
'bad dll calling convention, in rare circumstances
If Err.Number <> 0 Then
Err.Clear
End If
End Property
'-----------------------------------------------------------------------------------------------
' DEFAULT PROPERTY: need to export and add the following to this procedure, below the first line
' Attribute Path.VB_UserMemId = 0
'-----------------------------------------------------------------------------------------------
Public Property Get Path() As String
Path = m_Path
End Property
'-----------------------------------------------------------------------------------------------
' Return just the path of a file object, regardless of its existence
'-----------------------------------------------------------------------------------------------
Public Property Get PathOnly() As String
'if it's a folder (created or not), we just want the path
If Me.IsFolder Then
PathOnly = Me.Path
'otherwise, remove the .Name part of it
Else
PathOnly = VBA.Replace(Me.Path, "\" & Me.Name, "")
End If
End Property
'-----------------------------------------------------------------------------------------------
' Easier way of getting the extension -- just remove the name without the extension
'-----------------------------------------------------------------------------------------------
Public Property Get Extension() As String
'remove the namewithout the extension from the name... returns nothing for folders
Extension = VBA.Replace(Me.Name, Me.NameWithoutExtension, "")
End Property
'-----------------------------------------------------------------------------------------------
' This is basically exactly the same as the Path property, but allow changing here too
' since this is an standard property of document objects, etc
'-----------------------------------------------------------------------------------------------
Public Property Get FullName() As String
FullName = m_Path
End Property
Public Property Let FullName(sFullName As String)
Me.Path = sFullName
End Property
'-----------------------------------------------------------------------------------------------
' can only return the MS-DOS ShortPath on a valid object,
' Returns blank for uncreated files/folders
'-----------------------------------------------------------------------------------------------
Public Property Get ShortPath() As String
On Error GoTo l_err
ShortPath = m_oMain.ShortPath
l_exit:
Exit Property

l_err:
ShortPath = ""
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' Initialize our file system object and two custom collections
'-----------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
Set m_oFSO = CreateObject("Scripting.FileSystemObject")
Set m_colFilesAll = New Collection
Set m_colSubFoldersAll = New Collection
End Sub
'-----------------------------------------------------------------------------------------------
' Garbage collection on terminating this class
'-----------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
Set m_oFSO = Nothing
Set m_oFolder = Nothing
Set m_oFile = Nothing
Set m_oMain = Nothing
Set m_colFilesAll = Nothing
Set m_colSubFoldersAll = Nothing
End Sub
'-----------------------------------------------------------------------------------------------
Public Property Get WhatType() As String
On Error GoTo l_err
WhatType = m_oMain.Type
l_exit:
Exit Property

l_err:
WhatType = ""
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' if the name and namewithoutextension don't match, it's a file, or *would* be, if created
'-----------------------------------------------------------------------------------------------
Public Property Get IsFile() As Boolean
If m_oFile Is Nothing Then
If Me.Name <> Me.NameWithoutExtension Then
IsFile = True
End If
Else
IsFile = True
End If
End Property
'-----------------------------------------------------------------------------------------------
' if the private folder object is nothing
' then check to see if the name and the name without extension match to determine whether the
' uncreated object *would* be a folder
'-----------------------------------------------------------------------------------------------
Public Property Get IsFolder() As Boolean
If m_oFolder Is Nothing Then
If Me.Name = Me.NameWithoutExtension Then
IsFolder = True
End If
Else
IsFolder = True
End If
End Property
'-----------------------------------------------------------------------------------------------
' if our main object isn't nothing, then the actual object exists
'-----------------------------------------------------------------------------------------------
Public Property Get Exists() As Boolean
If m_oMain Is Nothing = False Then
Exists = True
End If
End Property
'-----------------------------------------------------------------------------------------------
Public Property Get Attributes() As VbFileAttribute
On Error GoTo l_err
Attributes = m_oMain.Attributes
l_exit:
Exit Property
l_err:
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
Public Property Let Attributes(lAttributes As VbFileAttribute)
On Error GoTo l_err
m_oMain.Attributes = lAttributes
l_exit:
Exit Property
l_err:
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
Public Property Get DateCreated() As Date
On Error GoTo l_err
DateCreated = m_oMain.DateCreated
l_exit:
Exit Property
l_err:
DateCreated = 0
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
Public Property Get DateLastAccessed() As Date
On Error GoTo l_err
DateLastAccessed = m_oMain.DateLastAccessed
l_exit:
Exit Property
l_err:
DateLastAccessed = 0
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
Public Property Get DateLastModified() As Date
On Error GoTo l_err
DateLastModified = m_oMain.DateLastModified
l_exit:
Exit Property
l_err:
DateLastModified = 0
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
Public Property Get Drive() As Object
On Error GoTo l_err
Drive = m_oMain.Drive
l_exit:
Exit Property
l_err:
Set Drive = Nothing
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
Public Property Get Files() As Object
On Error GoTo l_err
If Me.IsFolder Then
Set Files = m_oMain.Files
End If
l_exit:
Exit Property
l_err:
Set Files = Nothing
Resume l_exit
End Property

[Frosty]

And Part 3

'-----------------------------------------------------------------------------------------------
' return all files (including any in our sub directories)
'-----------------------------------------------------------------------------------------------
Public Property Get FilesAll() As Collection
Set FilesAll = m_colFilesAll
End Property
'-----------------------------------------------------------------------------------------------
' private function for returning all files in the main folder and any sub folder
' in a single collection
'-----------------------------------------------------------------------------------------------
Private Function fGetAllFiles() As Collection
Dim oFile As Object
Dim oFolder As Object
Dim colRet As Collection

On Error GoTo l_err
Set colRet = New Collection
'get the files in the top level folder, if any
For Each oFile In Me.Files
colRet.Add oFile
Next
'and any in the subfolders all collection, if any
If Not Me.SubFoldersAll Is Nothing Then
For Each oFolder In Me.SubFoldersAll
For Each oFile In oFolder.Files
colRet.Add oFile
Next
Next
End If
If colRet.Count = 0 Then
Set colRet = Nothing
End If

l_exit:
Set fGetAllFiles = colRet
Exit Function
l_err:
Set colRet = Nothing
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
Public Property Get SubFolders() As Object
On Error GoTo l_err
If Me.IsFolder Then
Set SubFolders = m_oMain.SubFolders
End If
l_exit:
Exit Property
l_err:
Set SubFolders = Nothing
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' Return a collection of all subfolders as folder objects
'-----------------------------------------------------------------------------------------------
Public Property Get SubFoldersAll() As Collection
Set SubFoldersAll = m_colSubFoldersAll
End Property
'-----------------------------------------------------------------------------------------------
' A recursive function to return a collection of all Folder objects
' contained in our main object (if the main object is a Folder object)
' Returns NOTHING if main object isn't a folder, to mimic what the FileSystemObject returns
' for the SubFolders property of a File object
'-----------------------------------------------------------------------------------------------
Private Function fGetAllSubFolders(oInFolder As Object) As Collection
Dim oSubFolder As Object
Dim i As Integer
Dim colRet As Collection
Dim colRet2 As Collection

On Error GoTo l_err
Set colRet = New Collection
If oInFolder.SubFolders.Count > 0 Then
For Each oSubFolder In oInFolder.SubFolders
colRet.Add oSubFolder
Set colRet2 = fGetAllSubFolders(oSubFolder)
If Not colRet2 Is Nothing Then
For i = 1 To colRet2.Count
colRet.Add colRet2(i)
Next
End If
Next

Else
Set colRet = Nothing
End If
l_exit:
Set fGetAllSubFolders = colRet
Exit Function
l_err:
Set colRet = Nothing
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' Return the name property-- even if the file/folder doesn't exist
'-----------------------------------------------------------------------------------------------
Public Property Get Name() As String
On Error GoTo l_err
'if we don't have a valid object, then extrapolate from our private path variable
If m_oMain Is Nothing Then
If Right(m_Path, 1) = "\" Then
Name = VBA.Split(m_Path, "\")(UBound(VBA.Split(m_Path, "\")) - 1)
Else
Name = VBA.Split(m_Path, "\")(UBound(VBA.Split(m_Path, "\")))
End If
Else
Name = m_oMain.Name
End If
l_exit:
Exit Property
l_err:
Name = ""
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' Return the MS-DOS file name, if the object exists
'-----------------------------------------------------------------------------------------------
Public Property Get ShortName() As String
On Error GoTo l_err
ShortName = m_oMain.ShortName
l_exit:
Exit Property
l_err:
ShortName = ""
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' Gives file name without extension, if it is a file
' if a folder, gives same as regular name
'-----------------------------------------------------------------------------------------------
Public Property Get NameWithoutExtension() As String
Dim sCurName As String

sCurName = Me.Name
On Error GoTo l_err
'if we don't have a file extension separator
If VBA.InStr(sCurName, ".") = 0 Then
NameWithoutExtension = sCurName
Else
NameWithoutExtension = VBA.Left(sCurName, VBA.InStr(sCurName, ".") - 1)
End If
l_exit:
Exit Property
l_err:
NameWithoutExtension = ""
Resume l_exit
End Property
'-----------------------------------------------------------------------------------------------
' return the "path" of a passed string.
' ASSUMES last period in string indicates a file extension of a file
' C:\Test\test.txt returns C:\Test
' C:\Test\ or C:\Test returns C:\Test
'-----------------------------------------------------------------------------------------------
Private Function fGetPathFromString(ByVal sValue As String) As String
'if we've got a period, remove that area of the path string
If VBA.InStrRev(sValue, ".") > 0 Then
sValue = VBA.Left(sValue, VBA.InStrRev(sValue, "\") - 1)
End If
'remove the last path separator
If VBA.Right(sValue, 1) = "\" Then
sValue = VBA.Left(sValue, VBA.Len(sValue) - 1)
End If
'return it
fGetPathFromString = sValue
End Function

[gmaxey]

Jason,

Shouldn't Attribute Item.VB_UserMemId = 0 be:
Attribute Path.VB_UserMemId = 0

I had some trouble getting this to work. I don't know if it was because the code was split up or what. I had to create a new class template:
http://www.devx.com/vb2themax/Tip/18460
copy all of your code from my first attempt and paste it in this new class, then export the class, open in notepad and add the revised line, import the class and it worked.

Haven't had time to test thoroughly.

[Frosty]

You're absolutely right, and further it should actually be in the Get property. So in notepad, that area of the .cls module should look like this:

'-----------------------------------------------------------------------------------------------
' DEFAULT PROPERTY: need to export and add the following to this procedure, below the first line
' Attribute Path.VB_UserMemId = 0
'-----------------------------------------------------------------------------------------------
Public Property Get Path() As String
Attribute Path.VB_UserMemId = 0
Path = m_Path
End Property


I will update my comments... thank you!

[gmaxey]

It seems to work where I have it under Let as well.

Break

I didn't break the class but I can break the demo prety easily if there is no sub-folder in the main folder tested.

Easily fixed with a test for Nothing.
If Not oMyFSO.SubFoldersAll Is Nothing Then
For Each oFolder In oMyFSO.SubFoldersAll

Again, I've not had time to really study the class, but it seems a .HasSubFolder property might be handy:

If oMyFSO.HasSubFolder Then
For Each oFolder In oMyFSO.SubFoldersAll

[fumei]

"open the exported class in Notepad, and add the text "Attribute Item.VBUserMemID = 0"

why do you have to export and open that in Notepad?

[Frosty]

Excellent, thanks. Since I want the .FilesAll and .SubFoldersAll collections to mimic the behavior of the .Files and .SubFolders built-in properties of the FileSystemObject, rather than add the .HasSubFolder property (or do a test for Nothing before doing a For Each loop), I would approach it this way:

1. Change both fGetAllFiles and fGetAllSubFolders to return an empty (but initialized) collection rather than Nothing. So those two procedures would now be this:

'-----------------------------------------------------------------------------------------------
' private function for returning all files in the main folder and any sub folder
' in a single collection
'-----------------------------------------------------------------------------------------------
Private Function fGetAllFiles() As Collection
Dim oFile As Object
Dim oFolder As Object
Dim colRet As Collection

On Error GoTo l_err
Set colRet = New Collection
'get the files in the top level folder, if any
For Each oFile In Me.Files
colRet.Add oFile
Next
'and any in the subfolders all collection, if any
If Not Me.SubFoldersAll Is Nothing Then
For Each oFolder In Me.SubFoldersAll
For Each oFile In oFolder.Files
colRet.Add oFile
Next
Next
End If

l_exit:
Set fGetAllFiles = colRet
Exit Function
l_err:
Set colRet = Nothing
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' A recursive function to return a collection of all Folder objects
' contained in our main object (if the main object is a Folder object)
'-----------------------------------------------------------------------------------------------
Private Function fGetAllSubFolders(oInFolder As Object) As Collection
Dim oSubFolder As Object
Dim i As Integer
Dim colRet As Collection
Dim colRet2 As Collection

On Error GoTo l_err
Set colRet = New Collection
If oInFolder.SubFolders.Count > 0 Then
For Each oSubFolder In oInFolder.SubFolders
colRet.Add oSubFolder
Set colRet2 = fGetAllSubFolders(oSubFolder)
If Not colRet2 Is Nothing Then
For i = 1 To colRet2.Count
colRet.Add colRet2(i)
Next
End If
Next
End If
l_exit:
Set fGetAllSubFolders = colRet
Exit Function
l_err:
Set colRet = Nothing
Resume l_exit
End Function


2. Change the demo code to check the .Exists and the .IsFolder property. Then the For Each loops will work in both cases, but the .Files, .FilesAll, .SubFolders and .SubFoldersAll will return Nothing when the class is referring to a File.
That would look like this:

Sub Demo_IterateThroughAllFilesAndFolders()
Dim oMyFSO As New clsFSO
Dim oFile As Object
Dim oFolder As Object

oMyFSO.Path = "C:\Temp"
'if you set up the default property, you could use this line...
'oMyFSO = "C:\Temp"

If oMyFSO.Exists And oMyFSO.IsFolder Then
For Each oFile In oMyFSO.FilesAll
Debug.Print oFile.Path
Next

For Each oFolder In oMyFSO.SubFoldersAll
Debug.Print oFolder.Path
Next
Else
Debug.Print oMyFSO.Path & " doesn't exist!"
End If

End Sub

Does that work?

[Frosty]

Fumei: the only way to set a default property of a VBA class module is to export the class, open it in notepad, and then manually put that text in. Greg's link in an earlier post on this thread contains more info about that.

The reasoning is so that you can have
Dim x as New clsFSO
x = "C:\MyPath"

If you don't do the export process, then there's no default property, so you would explicitly have to reference the .Path property, a la...
x.Path = "C:\MyPath"

EDIT: the devx link explains more about the VBAttributes, but basically they are ways of prettying up your custom class for being explored via the object browser (which can be useful if you're not going to expose the actual class code, for example: a password protected template project).

[gmaxey]

Jason,

Yes that works. Thanks.


Excellent, thanks. Since I want the .FilesAll and .SubFoldersAll collections to mimic the behavior of the .Files and .SubFolders built-in properties of the FileSystemObject, rather than add the .HasSubFolder property (or do a test for Nothing before doing a For Each loop), I would approach it this way:

1. Change both fGetAllFiles and fGetAllSubFolders to return an empty (but initialized) collection rather than Nothing. So those two procedures would now be this:

'-----------------------------------------------------------------------------------------------
' private function for returning all files in the main folder and any sub folder
' in a single collection
'-----------------------------------------------------------------------------------------------
Private Function fGetAllFiles() As Collection
Dim oFile As Object
Dim oFolder As Object
Dim colRet As Collection

On Error GoTo l_err
Set colRet = New Collection
'get the files in the top level folder, if any
For Each oFile In Me.Files
colRet.Add oFile
Next
'and any in the subfolders all collection, if any
If Not Me.SubFoldersAll Is Nothing Then
For Each oFolder In Me.SubFoldersAll
For Each oFile In oFolder.Files
colRet.Add oFile
Next
Next
End If

l_exit:
Set fGetAllFiles = colRet
Exit Function
l_err:
Set colRet = Nothing
Resume l_exit
End Function
'-----------------------------------------------------------------------------------------------
' A recursive function to return a collection of all Folder objects
' contained in our main object (if the main object is a Folder object)
'-----------------------------------------------------------------------------------------------
Private Function fGetAllSubFolders(oInFolder As Object) As Collection
Dim oSubFolder As Object
Dim i As Integer
Dim colRet As Collection
Dim colRet2 As Collection

On Error GoTo l_err
Set colRet = New Collection
If oInFolder.SubFolders.Count > 0 Then
For Each oSubFolder In oInFolder.SubFolders
colRet.Add oSubFolder
Set colRet2 = fGetAllSubFolders(oSubFolder)
If Not colRet2 Is Nothing Then
For i = 1 To colRet2.Count
colRet.Add colRet2(i)
Next
End If
Next
End If
l_exit:
Set fGetAllSubFolders = colRet
Exit Function
l_err:
Set colRet = Nothing
Resume l_exit
End Function


2. Change the demo code to check the .Exists and the .IsFolder property. Then the For Each loops will work in both cases, but the .Files, .FilesAll, .SubFolders and .SubFoldersAll will return Nothing when the class is referring to a File.
That would look like this:

Sub Demo_IterateThroughAllFilesAndFolders()
Dim oMyFSO As New clsFSO
Dim oFile As Object
Dim oFolder As Object

oMyFSO.Path = "C:\Temp"
'if you set up the default property, you could use this line...
'oMyFSO = "C:\Temp"

If oMyFSO.Exists And oMyFSO.IsFolder Then
For Each oFile In oMyFSO.FilesAll
Debug.Print oFile.Path
Next

For Each oFolder In oMyFSO.SubFoldersAll
Debug.Print oFolder.Path
Next
Else
Debug.Print oMyFSO.Path & " doesn't exist!"
End If

End Sub

Does that work?

[MacroShadow]

The demo breaks by me if the oMyFSO.Path doesn't have any files in it.

[MacroShadow]

btw, for the past several years I've been using a FSO replacement written by David W. Fenton, and addapted by myself for use in Word.

[Frosty]

Thanks for posting that link, MacroShadow.

Also--was the demo breaking after the adjustments made later in the thread (having the custom collections return empty rather than initialized)?

[MacroShadow]

I didn't try the first version.

[Frosty]

MacroShadow, I'm not getting the same results. Iterating through the .FilesAll and .SubFoldersAll collections using a For Each loop works, regardless of whether there are any subfolders or files in the folder I'm pointed at.

Of course, if I'm pointed at a non-existent folder, that's different-- but that's what the .Exists property is for.

Are you sure you incorporated the changes in this thread (I don't want to post the entire code again for what amounts to 3 lines of changed code)?

Also, as an fyi -- the replacement code for the removed FileSearch functionality in 2007/2010 is a kind of different purpose, although I see the similarity. The goals, however, were the same, such as they are:
1. Use of Late-Binding without the loss of autocomplete functionality (so I don't have to go research filesystemobject methods and properties every time I encounter some area I haven't played with).

2. A couple additional tweaks that I wish the original object had anyway (a simple collection built recursively, so I don't have to build one on the fly when I need to go through all folders/subfolders contained in a single location).

Similar in concept, but a slightly different implementation, as David Fenton was recreating different functionality.

Thanks again for adding your eyeballs to the above code. Please let me know what's actually breaking (if anything), as I can't recreate with the changes Greg and I worked out.

[MacroShadow]

I'm not sure what I'm doing wrong. I get a compile error: Invalid use of Me keyword on the For Each oFile In Me.Files line, in the new fGetAllFiles function.
If I run the code anyway, it runs in a infinite (?) loop.
For i = 1 To colRet2.Count
colRet.Add colRet2(i)
Next

Attached is the problematic file.

[Frosty]

those aren't new functions, those functions exist in the class code previously posted. They're simply updates, in that they remove a couple of lines of code which would have set the return of the function to Nothing, rather than an empty (but initialized) collection object.

If you create the class in your project the way it's detailed in the original posts (3 separate posts to get all the class code), and then update the two functions within the class code with the later updates, the original demo code should work.

Does that make sense?

I can post a sample document for you, if you prefer... but that may very well get out of date as well. I was trying to avoid posting multiple attachment documents because I wanted to have a discussion (if possible) about the code, without having to download attachments.

[Frosty]

Well, it was instructive to download your attachment, because I can see what you're attempting, which is to point this class object to the C:\ instead of a subfolder.

Mine errors out on .FilesAll property (although the .SubFoldersAll collection works).

But I clearly need to put in a delimiter for these recursive functions if someone points to an entire drive. My .SubFoldersAll collection returns 21k+ folders. There will obviously be many many more files than 21,832 (since that's just the number of subfolders), and I'm sure at some point VBA is either running out of space or encountering something *bad* during the recursive function).

So, a couple of suggestions:
1. Don't point it at C:\. Point it at a subfolder (I'd probably avoid C:\Windows as well).
2. Remove your module which has those functions, and instead replace the functions of the same name in the clsFSO code.

Thanks for playing with it.

Anyone have any ideas on a rational limiter to this functionality, or should it just be a caveat emptor kind of functionality?