I have found Scripting.FileSystemObject to be slow and unstable. Calling file_object.Name repeatedly has caused my code to crash excel on multiple instances. Therefore I made a module where all of my file System helper functions reside. I called it os after python's os module as I tried to emulate it as much as possible. Admittedly, I have not emulated it enough and much is written from scratch.
While I haven't been able to run extensive comparisons against it and FileSystemObject. I have found that it is significantly faster. It varies from operation to operation but the range is 4-10 times faster. However, I do suspect that FileSystemObject may out-perform os in larger data-sets.
There are some few questionable design calls. Nothing is object oriented. Functional programming is preferred whenever possible. Almost all variables are strings (file paths) or collections of strings. The exceptions are the file system operations like FileCopy, Move, Rename etc that return True if succeeded or False if failed as Error Handling is a horrid mess of GoTos in VB6. Also they are hard set to never overwrite files; only Remove deletes anything.
I am looking for more functions, features and improvements for existing functions.
Option Explicit
' Constants
' ------
Public Const EXTSEP As String = "."
Public Const PARDIR As String = ".."
Public Const CURDIR As String = "."
Public Const SEP As String = "\"
Public Const PATHSEP As String = ";"
Private Const ALLPAT As String = "*"
Path Manipulations
These functions would be in os.path. They have no interaction with the file system at all and are primarily helper functions.
''
' Returns the base name of a path, either the lowest folder or file
' Note! that `suffix` will be removed from the end regardless if its an actual filename
' extension or not.
Function BaseName(ByVal file_path As String, Optional suffix As String) As String
Dim fsplit As Variant
fsplit = Split(file_path, sep)
BaseName = fsplit(UBound(fsplit))
If suffix <> "" Then
Dim base_length As Integer
base_length = Len(BaseName) - Len(suffix)
BaseName = left$(BaseName, base_length) & _
Replace$(BaseName, suffix, "", base_length + 1)
End If
End Function
''
' Returns the path of the parent folder. This is the opposite of `BaseName`.
Function RootName(ByVal file_path As String) As String
Dim fsplit As Variant
fsplit = Split(file_path, sep)
If UBound(fsplit) = 0 Then
RootName = ""
Else
Dim i As Integer
For i = LBound(fsplit) To UBound(fsplit) - 1
RootName = RootName & fsplit(i) & SEP
Next i
RootName = left$(RootName, Len(RootName) - 1)
End If
End Function
Function ParentDir(ByVal file_path As String, _
ByVal parent_height As Integer) As String
ParentDir = file_path
Dim i As Integer
For i = 1 To parent_height
ParentDir = RootName(ParentDir)
Next i
End Function
''
' Returns the file extension of the file.
Function ext(ByVal file_path As String) As String
Dim base_name As String
base_name = BaseName(file_path)
If InStr(base_name, EXTSEP) Then
Dim fsplit As Variant
fsplit = Split(base_name, EXTSEP)
ext = EXTSEP & fsplit(UBound(fsplit))
End If
End Function
Function ChangeExt(ByVal file_path As String, ByVal new_ext As String) As String
Dim current_ext As String
current_ext = ext(file_path)
ChangeExt = left$(file_path, Len(file_path) - Len(current_ext)) & _
EXTSEP & Replace$(new_ext, EXTSEP, "", 1, 1)
End Function
Private Function RTrimSep(ByVal file_path As String) As String
If right$(file_path, 1) = sep Then
RTrimSep = left$(file_path, Len(file_path) - 1)
Else
RTrimSep = file_path
End If
End Function
''
' safely join two strings to form a path
Function pJoin(ByVal root_path As String, ByVal file_path As String) As String
pJoin = RTrimSep(root_path) & SEP & file_path
End Function
Function Append(ByVal file_path As String, ByVal to_append As String) As String
Dim file_ext As String
file_ext = ext(file_path)
Append = pJoin(RootName(file_path), _
BaseName(file_path, suffix:=file_ext) & _
to_append & file_ext)
End Function
Function Prepend(ByVal file_path As String, ByVal to_prepend As String) As String
Prepend = pJoin(RootName(file_path), to_prepend & BaseName(file_path))
End Function
Introspect File System
The following functions read the file system but make no changes.
''
' returns true if the file exists else false.
' You can give a pat as f to see if anything matches the pat
Function Exists(ByVal file_path As String, _
Optional vbType As Integer = vbDirectory) As Boolean
If file_path <> "" Then Exists = (Dir$(RTrimSep(file_path), vbType) <> "")
End Function
Function FileExists(ByVal file_path As String)
FileExists = Exists(file_path, vbNormal)
End Function
''
' vbDirectory option still includes files.
' FML
Function FolderExists(ByVal file_path As String)
FolderExists = Exists(file_path, vbDirectory) And Not Exists(file_path, vbNormal)
End Function
''
' returns a collection of strings that are paths of subitems in root which
' match pat.
Function SubItems(ByVal root As String, Optional pat As String = ALLPAT, _
Optional vbType As Integer = vbDirectory) As Collection
Set SubItems = New Collection
Dim sub_item As String
sub_item = Dir$(pJoin(root, pat), vbType)
While sub_item <> ""
SubItems.Add (pJoin(root, sub_item))
sub_item = Dir$()
Wend
End Function
Function SubFiles(ByVal root As String, _
Optional pat As String = ALLPAT) As Collection
Set SubFiles = SubItems(root, pat, vbNormal)
End Function
Function SubFolders(ByVal root As String, Optional pat As String = "", _
Optional skipDots As Boolean = True) As Collection
Set SubFolders = SubItems(root, pat, vbDirectory)
If skipDots And SubFolders.count > 0 Then
Dim dot As String, dotdot As String
dot = pJoin(root, CURDIR)
dotdot = pJoin(root, PARDIR)
Do While SubFolders.Item(1) = dot Or SubFolders.Item(1) = dotdot
SubFolders.Remove (1)
If SubFolders.count = 0 Then Exit Do
Loop
End If
Dim i As Integer
For i = SubFolders.count To 1 Step -1
If FileExists(SubFolders.Item(i)) Then
SubFolders.Remove (i)
End If
Next i
End Function
''
' recursive search
Sub sWalk(ByVal root As String, ByRef collec As Collection, _
Optional pat As String = "*", Optional vbType As Integer = vbNormal)
Dim file_path As Variant
For Each file_path In SubItems(root, pat, vbType)
collec.Add file_path
Next file_path
Dim folder_path As Variant
For Each folder_path In SubFolders(root)
sWalk folder_path, collec, pat, vbType
Next folder_path
End Sub
Function fWalk(ByVal root As String, Optional pat As String = "*", _
Optional vbType As Integer = vbNormal) As Collection
Set fWalk = New Collection
sWalk root, fWalk, pat, vbType
End Function
File System Operations
The following functions are the only functions that actually change the file system. Note that only Remove deletes any data. The rest will return False if they would remove or overwrite any data, or if they cannot perform the operation for any other reason.
Function Move(ByVal file_path As String, ByVal new_path As String, _
Optional create_parent As Boolean = False) As Boolean
Move = Exists(file_path) And Not Exists(new_path)
If Move Then
If create_parent Then CreateRootPath new_path
Name file_path As new_path
End If
End Function
Function Rename(ByVal file_path As String, ByVal new_name As String) As Boolean
Debug.Assert BaseName(new_name) = new_name
new_name = pJoin(RootName(file_path), new_name)
Rename = Exists(file_path) And Not Exists(new_name)
If Rename Then Name file_path As new_name
End Function
Function Remove(file_path As String) As Boolean
Remove = FileExists(file_path)
If Remove Then Kill file_path
End Function
''
' $ mkdir -p
Private Sub CreateRootPath(file_path As String)
If Not Exists(RootName(file_path)) Then
MakeDir RootName(file_path), create_parent:=True
End If
End Sub
Function MakeDir(folder_path As String, _
Optional create_parent As Boolean = False) As Boolean
MakeDir = Not Exists(folder_path)
If MakeDir Then
If create_parent Then CreateRootPath folder_path
MkDir folder_path
End If
End Function
Function CopyFile(file_path As String, dest_path As String, _
Optional create_parent As Boolean = False) As Boolean
CopyFile = Exists(file_path) And Not Exists(dest_path)
If CopyFile Then
If create_parent Then CreateRootPath dest_path
FileCopy file_path, dest_path
End If
End Function
Error Handling
I implemented the Error Handling as suggested. I noticed I could remove almost all of my guards because the VB methods would throw errors anyways. Except for FileCopy which would overwrite existing files.
Function Move(ByVal src_path As String, ByVal dest_path As String, _
Optional create_parent As Boolean = False) As Boolean
Dim check As Boolean
On Error GoTo ErrHandler
If right$(dest_path, 1) = SEP Or FolderExists(dest_path) Then
' Move the file to a folder. Note this cannot be used with the
' create_parent option.
dest_path = pJoin(dest_path, BaseName(src_path))
End If
If create_parent Then CreateRootPath dest_path
Name src_path As dest_path
check = Exists(dest_path)
CleanExit:
Move = check
Exit Function
ErrHandler:
Err.clear
Debug.Assert (Not check)
Resume CleanExit
End Function
Function Rename(ByVal file_path As String, ByVal new_name As String) As Boolean
Debug.Assert BaseName(new_name) = new_name
Rename = Move(file_path, pJoin(RootName(file_path), new_name))
End Function
Function Remove(file_path As String) As Boolean
Dim check As Boolean
On Error GoTo ErrHandler
Kill file_path
check = (Not FileExists(file_path))
CleanExit:
Remove = check
Exit Function
ErrHandler:
Err.clear
Debug.Assert (Not check)
Resume CleanExit
End Function
Function MakeDir(folder_path As String, _
Optional create_parent As Boolean = False) As Boolean
Dim check As Boolean
On Error GoTo ErrHandler
If create_parent Then CreateRootPath folder_path
MkDir folder_path
check = FolderExists(folder_path)
CleanExit:
MakeDir = check
Exit Function
ErrHandler:
Err.clear
Debug.Assert (Not check)
Resume CleanExit
End Function
Function CopyFile(src_path As String, dest_path As String, _
Optional create_parent As Boolean = False) As Boolean
Dim check As Boolean
On Error GoTo ErrHandler
If FileExists(dest_path) Then GoTo CleanExit:
If create_parent Then CreateRootPath dest_path
FileCopy src_path, dest_path
check = FileExists(dest_path)
CleanExit:
CopyFile = check
Exit Function
ErrHandler:
Err.clear
Debug.Assert (Not check)
Resume CleanExit
End Function
Private Sub CreateRootPath(path As String)
Dim parent_folder As String
parent_folder = RootName(path)
If Not FolderExists(parent_folder) Then
MakeDir parent_folder, create_parent:=True
End If
End Sub
