VBA Snippets


File_Copy

Copies a file from one folder to another.
Public Sub File_Copy( _
ByVal sFolderFrom As String, _
ByVal sFileNameFrom As String, _
ByVal sFolderTo As String, _
ByVal sFileNameTo As String, _
Optional ByVal sExtensionFrom As String = "", _
Optional ByVal sExtensionTo As String = "")

Const sPROCNAME As String = "File_Copy"
On Error GoTo AnError

sFolderFrom = Folder_LineAdd(sFolderFrom)
sFolderTo = Folder_LineAdd(sFolderTo)

Call FileCopy(sFolderFrom & sFileNameFrom & sExtensionFrom, _
sFolderTo & sFileNameTo & sExtensionTo)

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"copy the file """ & sFileNameFrom & sExtensionFrom & """ from """ & vbCrLf & _
"""" & sFolderFrom & """" & vbclrf & _
"to the folder " & vbCrLf & _
"""" & sFolderTo & """" & vbCrLf & _
"with the name """ & sFileNameTo & sExtensionTo)
End Sub

File_Delete

Removes a file. Add an optional confirmation prompt.
Public Sub File_Delete( _
ByVal sFolderPath As String, _
ByVal sFileName As String)

Const sPROCNAME As String = "File_Delete"
On Error GoTo ErrorHandler

If Len(Dir(sFolderPath & sFileName)) > 0 Then
SetAttr sFolderPath & sFileName, vbNormal
Kill sFolderPath & sFileName
End If

Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Sub

File_DeleteFSO

Public Sub File_DeleteFSO( _
ByVal sFolderPath As String, _
ByVal sFileName As String)

Const sPROCNAME As String = "File_DeleteFSO"
On Error GoTo ErrorHandler

Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Sub

File_DialogFilePicker

Displays a dialog box to allow the user to browse to a file.
Public Function File_DialogFilePicker( _
ByVal sFolderPath As String, _
ByVal sDialogTitle As String, _
Optional ByVal bInformUser As Boolean = True) _
As String

Const sPROCNAME As String = "File_DialogFilePicker"
Dim objFileDialog As FileDialog
Dim vfullpath As Variant
Dim sFullPath As String
On Error GoTo AnError

Set objFileDialog = Application.FileDialog(msoFileDialogFilePicker)

objFileDialog.Title = sDialogTitle
objFileDialog.AllowMultiSelect = False
objFileDialog.InitialFileName = sFolderPath

objFileDialog.Show

For Each vfullpath In objFileDialog.SelectedItems
sFullPath = CStr(vfullpath)
Next

If Len(sFullPath) = 0 Then
If bInformUser = True Then
Call MsgBox("No file has been selected !!", , "Better Solutions")
End If
End If

File_DialogFilePicker = sFullPath

If gbDEBUG = False Then Exit Function

AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Function

File_Exists

Public Function File_Exists( _
ByVal sFileName As String) As Boolean

Const sPROCNAME As String = "File_Exists"
Dim sreturn As String
On Error GoTo ErrorHandler

sreturn = VBA.Dir(sFileName)
If Len(sreturn) > 0 Then
File_Exists = True
Else
File_Exists = False
End If

Exit Function
ErrorHandler:
File_Exists = False
End Function

File_ExistsFSO

Public Function File_ExistsFSO( _
ByVal sFileName As String) As Boolean

Const sPROCNAME As String = "File_ExistsFSO"
Dim sreturn As String
On Error GoTo ErrorHandler

Exit Function
ErrorHandler:
File_Exists = False
End Function

File_ExtAdd

Adds a particular extension to a given filename if it does not have an extension.
Public Function File_ExtAdd(
ByVal sFileName As String, _
ByVal sExtension As String) As String

Const sPROCNAME As String = "File_ExtAdd"
Dim balter As Boolean
On Error GoTo AnError

balter = False
If sFileName <> "" Then
If UCase(Right(sFileName, 4)) <> UCase(sExtension) Then balter = True
If balter = True Then
If InStr(sFileName, ".") > 0 Then
File_ExtAdd = sFileName
Else
File_ExtAdd = sFileName & LCase(sExtension)
End If
End If
If balter = False Then _
File_ExtAdd = Left(sFileName, Len(sFileName) - 4) & LCase(sExtension)
Else
File_ExtAdd = ""
End If

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(sPROCNAME, msMODULENAME, 1,
"add the extension """ & sExtension & """ to the filename " & vbCrLf & _
"""" & sFileName & """")
End Function

File_ExtRemove

Removes the file extension from a filename if it has one.
Public Function File_ExtRemove(
ByVal sFileName As String, _
ByVal sExtension As String) As String

Const sPROCNAME As String = "File_ExtRemove"
Dim balter As Boolean
On Error GoTo AnError

balter = False
If sFileName <> "" Then
If UCase(Right(sFileName, 4)) <> UCase(sExtension) Then balter = True
If balter = True Then File_ExtRemove = sFileName
If balter = False Then File_ExtRemove = Left(sFileName, Len(sFileName) - 4)
Else
File_ExtRemove = ""
End If

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(sPROCNAME, msMODULENAME, 1,
"remove the extension """ & sExtension & """ from the filename " & _
vbCrLf & """" & sFileName & """")
End Function

File_GetFirst

Returns the filename of the first file in a folder with a particular extension. This is used when you want to manipulate all the files in a folder.
Public Function File_GetFirst( _
ByVal sFolderPath As String, _
ByVal sExtension As String) _
As String

On Error GoTo AnError

File_GetFirst = Dir(sFolderPath & "*" & sExtension, vbNormal)
If File_GetFirst = "" Then
Call MsgBox( _
"There are no files with extension " & _
"""" & sExtension & """" & vbCrLf & _
"in the Directory : " & """" & sFolderPath & """")
End If

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("File_GetFirst", msMODULENAME, 1,
"return the first file in the folder" & vbCrLf & sFolderPath)
End Function

File_GetNext

Returns the next filename in a folder. This is used when you have to manipulate all the files in a folder.
Public Function File_GetNext( _
ByVal sCurrentFileName As String, _
Optional ByVal sFolderPath As String = "") _
As String

Dim snextfilename As String

On Error GoTo AnError
snextfilename = Dir()
If (File_GetNext <> sCurrentFileName) Then
File_GetNext = snextfilename
End If

If gbDEBUG = False Then Exit Function
AnError:
File_GetNext = ""
Call Error_Handle("File_GetNext", msMODULENAME, 1,
"return the next file in the folder" & vbCrLf & sFolderPath & vbCrLf & _
"The last file obtained was """ & sCurrentFileName & """")
End Function

File_LastModifiedDate

Returns the date that a file was last modified.
Public Function File_LastModifiedDate( _
ByVal sFolderPath As String, _
ByVal sFileName As String, _
ByVal sExtension As String) _
As String

On Error GoTo AnError
File_DateLastModified = Left(FileDateTime(sFolderPath & sFileName & sExtension), 10)

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("File_LastModifiedDate", msMODULENAME, 1,
"")
End Function

File_LastModifiedTime

Returns the time that a file was last modified.
Public Function File_LastModifiedTime( _
ByVal sFolderPath As String, _
ByVal sFileName As String, _
ByVal sExtension As String) _
As String

On Error GoTo AnError

File_TimeLastModified = Right(FileDateTime(sFolderPath & sFileName & sExtension), 8)

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("File_LastModifiedTime", msMODULENAME, 1,
"")
End Function

File_NameUnique

Returns the unique filename with the corresponding number in brackets added to the end. This number ensures the filename is unique. If a file with the same name currently exists then the necessary number in the sequence is added to make it unique.
Public Function File_NameUnique( _
ByVal sFileName As String) As String

Dim stempfilename As String

On Error GoTo ErrorHandler

inooffiles = 2
'check whether the attachment already exists and if so then how many occurances
Do Until Dir(sFolderPath & stempfilename & sExtension) = ""
'the temporary file name is changed to produce a unique file name
stempfilename = sFileName & "(" & inooffiles & ")"
inooffiles = inooffiles + 1
Loop

File_NameUnique = stempfilename

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("File_NameUnique", msMODULENAME, 1,
"return the unique filename" & _
" with the corresponding number in brackets added to the end")
End Function

File_OpenDialog

Displays a dialog box to allow the user to open a file.
Public Function File_OpenDialog( _
ByVal sDialogPrefix As String, _
ByVal sFolderPath As String, _
ByVal sFilterName As String, _
ByVal sFilterExtensions As String, _
Optional ByVal bExecute As Boolean = True, _
Optional ByVal bMultiSelect As Boolean = False) _
As String

Dim objFileDialog As Office.FileDialog
Dim objFileDialogFilters As Office.FileDialogFilters
Dim sFileName As String

On Error GoTo ErrorHandler
Set objFileDialog = Application.FileDialog(msoFileDialogOpen)
With objFileDialog
.Title = sDialogPrefix & "File Open"
.InitialFileName = sFolderPath
.InitialView = msoFileDialogViewList
.Filters.Clear
.Filters.Add sFilterName, sFilterExtensions
.AllowMultiSelect = bMultiSelect
If .Show = True Then
If bExecute = True Then
.Execute
File_OpenDialog = "Opened"
Else
File_OpenDialog = .SelectedItems(1)
End If
Else
File_OpenDialog = ""
Exit Function
End If
End With

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("File_OpenDialog", msMODULENAME, 1, _
"display the File Open dialog box.")
End Function

File_OpenIsIt

Determines if a file is already open. Returns True or False.
Public Function File_OpenIsIt( _
ByVal sFolderPath As String, _
ByVal sFileName As String, _
Optional ByVal sExtension As String = ".xlsx") _
As Boolean

On Error GoTo ErrorHandler

Open sFolderPath & sFileName & sExtension For Binary Access Read Lock Read As #1
Close #1

If gbDEBUG = False Then Exit Function
ErrorHandler:
File_GetNext = ""
Call Error_Handle("File_OpenIsIt", msMODULENAME, 1,
"determine if the file " & sFileName & sExtension & " is already open" & _
" in the folder" & vbCrLf & sFolderPath)
End Function

File_ReadOnlyIsIt

Determines if you only have read only access to a file. Returns True or False.
Public Function File_ReadOnlyIsIt( _
ByVal sFolderPath As String, _
ByVal sFileName As String, _
Optional ByVal sExtension As String = ".xlsx") _
As Boolean

On Error GoTo ErrorHandler


If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("File_ReadOnlyIsIt", msMODULENAME, 1,
"determine if the file " & sFileName & sExtension & " is Read Only" & _
" in the folder" & vbCrLf & sFolderPath)
End Function

File_Rename

Renames a file in a folder.
Public Sub File_Rename( _
ByVal sFolderPath As String, _
ByVal sOldFileName As String, _
ByVal sOldExtension As String, _
ByVal sNewFileName As String, _
ByVal sNewExtension As String)


Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
On Error GoTo ErrorHandler

Set oFolder = objFilesys.GetFolder(sFolderPath)

For Each oFile In oFolder.Files
If (oFile.Name = sOldFileName & sOldExtension) Then
oFile.Name = sNewFileName & sNewExtension
End If

Next oFile
Set oFile = Nothing

If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle("File_Rename", msMODULENAME, 1,
"")
End Sub

File_SaveAsDialog

Displays a dialog box to save the current file.
Public Function File_SaveAsDialog(
ByVal sDialogPrefix As String, _
ByVal sFolderPath As String, _
ByVal sDefaultFileName As String, _
Optional ByVal bExecute As Boolean = True, _
Optional ByVal bMultiSelect As Boolean = False) _
As String

Const sPROCNAME As String = "File_SaveAsDialog"
Dim objFileDialog As Office.FileDialog
Dim objFileDialogFilters As Office.FileDialogFilters
Dim sFileName As String
On Error GoTo ErrorHandler

Set objFileDialog = Application.FileDialog(msoFileDialogSaveAs)
With objFileDialog

.Title = sDialogPrefix & "File Save As"
.InitialFileName = sFolderPath & sDefaultFileName
.InitialView = msoFileDialogViewList
If .Show = True Then
sFileName = Folder_PathRemove(.SelectedItems(1))
If Wbk_OpenIsIt(sFileName) = False Then
If bExecute = True Then

Application.DisplayAlerts = False
.Execute
Application.DisplayAlerts = True
File_SaveAsDialog= "Saved"
Else
'folder path and file are passed back to be processed
File_SaveAsDialog= .SelectedItems(1)
End If
Else
Call MsgBox("You cannot save this workbook with the name '" & sFileName & "'." & _
vbCrLf & _
"There is a workbook already open with this name." & _
vbCrLf & _
"Please close the other workbook first.", _
vbInformation + vbOKOnly, _
"BET: Workbook Not Saved")

File_SaveAsDialog= "Workbook Open"
End If
Else
File_SaveAsDialog= "Cancelled"
Exit Function
End If
End With

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(sPROCNAME, msMODULENAME, 1, _
"display the File Save As dialog box.")
End Function

File_Size

Returns the file size in kilobytes.
Public Function File_Size( _
ByVal sFileName As String) _
As Long

Dim ifileno As Integer

On Error GoTo ErrorHandler

ifileno = FreeFile
Open sFileName For Binary Access Read As #ifileno
File_Size= LOF(ifileno ) / 1024
Close #ifileno
'which method to use ???
File_Size= FileLen(intFile) / 1024

If gbDEBUG = False Then Exit Function
ErrorHandler:
File_Size = 0
Call Error_Handle("File_Size", msMODULENAME, 1,
"")
End Function

File_TextReadToArray

Public Function File_TextReadToArray( _
ByVal sFolderPath As String, _
ByVal sFilename As String, _
Optional ByVal sExtension As String = "", _
Optional ByVal sDelimiterChar As String = vbTab, _
Optional ByVal iNoOfColumns As Long = -1, _
Optional ByVal bInformUser As Boolean = True) _
As Variant

Dim objFSO As Scripting.FileSystemObject
Dim scrText As Scripting.TextStream

Dim slineoftext As String
Dim stotalcontents As String
Dim vacontents As Variant
Dim lnooflines As Long

On Error GoTo ErrorHandler

Set objFSO = New FileSystemObject
If (objFSO.FileExists(sFolderPath & sFilename & sExtension) = True) Then
Set scrText = objFSO.OpenTextFile(sFolderPath & sFilename & sExtension, ForReading)
Else
If (bInformUser = True) Then
Call MsgBox("This file does not exist - unable to return the contents.")
Exit Function
End If
End If

stotalcontents = ""
lnooflines = 1
Do While Not scrText.AtEndOfStream
slineoftext = scrText.ReadLine

stotalcontents = stotalcontents & slineoftext & "^"
lnooflines = lnooflines + 1
Loop

Set scrText = Nothing
Set objFSO = Nothing

ReDim vacontents(1 To lnooflines - 1) As Variant

'remove the last line seperator '^'
stotalcontents = Left(stotalcontents, Len(stotalcontents) - 1)

lnooflines = 1
Do While Len(stotalcontents) > 0
If InStr(1, stotalcontents, "^") > 0 Then
slineoftext = Left(stotalcontents, InStr(stotalcontents, "^") - 1)

stotalcontents = Right(stotalcontents, Len(stotalcontents) - Len(slineoftext) - 1)
Else
slineoftext = stotalcontents
stotalcontents = ""
End If

vacontents(lnooflines) = slineoftext
lnooflines = lnooflines + 1
Loop

File_TextReadToArray = vacontents
Exit Function

ErrorHandler:
Set scrText = Nothing
Set objFSO = Nothing
End Function

File_TextWrite

Public Function File_TextWriteFSO( _
ByVal sMessage As String, _
ByVal sFolderPath As String, _
ByVal sFilename As String, _
Optional ByVal sExtension As String = "", _
Optional ByVal bDeleteExistingFile As Boolean = False, _
Optional ByVal bInformUser As Boolean = True) _
As Boolean

Dim objFSO As Scripting.FileSystemObject
Dim scrText As Scripting.TextStream

On Error GoTo ErrorHandler

Set objFSO = New FileSystemObject
If objFSO.FileExists(sFolderPath & sFilename & sExtension) = False Then
Set scrText = objFSO.OpenTextFile(sFolderPath & sFilename & sExtension, ForWriting, True)
Else
Set scrText = objFSO.OpenTextFile(sFolderPath & sFilename & sExtension, ForAppending)
End If

scrText.WriteLine sMessage
scrText.Close

Set scrText = Nothing
Set objFSO = Nothing

File_TextWriteFSO = True
Exit Function

ErrorHandler:
Set scrText = Nothing
Set objFSO = Nothing
File_TextWriteFSO = False
End Function

Files_ToListCombo

Public Sub Files_ToListCombo(ByVal sFolderPath As String, _
ByVal sFileExtensionLIKE As String, _
ByVal oListComboBox As MSForms.control, _
Optional ByVal sExcludeFiles As String = "", _
Optional ByVal bClearList As Boolean = True, _
Optional ByVal bIncludePleaseSelect As Boolean = False, _
Optional ByVal bInformUser As Boolean = True, _
Optional ByVal bCheckFolderExists As Boolean = True, _
Optional ByVal bSelectAll As Boolean = False)

Const sPROCNAME As String = "Files_ToListCombo"
Dim sFullPath As String
Dim sExtension As String
Dim vFolder As Variant
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim arExcludeFiles() As String
Dim icount As Integer

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

If (sFolderPath = "") Then
Call modMessages.Message_FolderPathEmpty(sFolderPath)
Exit Sub
End If

Set g_objFSO = New Scripting.FileSystemObject
Set oFolder = g_objFSO.GetFolder(sFolderPath)

If (bCheckFolderExists = True) Then

End If

If (bClearList = True) Then
oListComboBox.Clear
End If

If (bIncludePleaseSelect = True) Then
oListComboBox.AddItem g_sPLEASE_SELECT
End If

For Each oFile In oFolder.Files
sFullPath = oFolder.Path & "\" & oFile.Name
sExtension = g_objFSO.GetExtensionName(sFullPath)
If (sExtension Like sFileExtensionLIKE) Then

If (Len(sExcludeFiles) = 0) Then
oListComboBox.AddItem oFile.Name
Else
arExcludeFiles = VBA.Split(sExcludeFiles, ";")
If (modGeneral.Array_ItemExists(arExcludeFiles, oFile.Name) = False) Then
oListComboBox.AddItem oFile.Name
End If
End If

End If
Next oFile

If (bSelectAll = True) Then
For icount = 0 To oListComboBox.ListCount - 1
oListComboBox.Selected(icount) = True
Next icount
End If

If g_bDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Folder_Browse

Displays the dialog box to allow the user to browse to a folder.
Public Function Folder_Browse() As String

Dim bInfo As BROWSEINFO
Dim sFolderPath As String
Dim lreturn As Long
Dim x As Long
On Error GoTo ErrorHandler

bInfo.pidlRoot = 0& 'root folder = desktop
bInfo.lpszTitle = "Select a folder"
bInfo.ulFlags = &H1 'type of directory to return
sFolderPath = Space(512) 'fill the string with spaces
lreturn = SHGetPathFromIDList(ByVal SHBrowseForFolder(bInfo), ByVal sFolderPath)
If lreturn = 1 Then
Folder_Browse = Left(sFolderPath, InStr(sFolderPath, Chr(0)) - 1) & "\"
Else
Folder_Browse = ""
End If

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_Browse", msMODULENAME, 1, _
"browse to a particular folder and return the path")
End Function

Folder_CanAccessFSO

Public Function Folder_CanAccessFSO( _
ByVal sFolderPath As String, _
Optional ByVal bInformUser As Boolean = True) _
As Boolean

Dim objFSOObject As Scripting.FileSystemObject
On Error GoTo AnError

Set objFSOObject = New Scripting.FileSystemObject
Folder_CanAccess = objFSOObject.FolderExists(sFolderPath)

If Folder_CanAccess = False Then
Call MsgBox("You are unable to access the following folder:" & vbCrLf & vbCrLf & _
"'" & sFolderPath & "'", vbInformation + vbOKOnly, "Title")
End If

Set objFSOObject = Nothing
Exit Function

AnError:
Set objFSOObject = Nothing
Folder_CanAccess = False
If bInformUser = True Then
Call MsgBox("You are unable to access the following folder:" & vbCrLf & vbCrLf & _
"'" & sFolderPath & "'", vbInformation + vbOKOnly, "Title")
End If
End Function

Folder_Create

Creates a folder. This will create sub folders if necessary as it starts at the top level.
Public Function Folder_Create( _
ByVal sFolderPath As String, _
Optional ByVal bInformUser As Boolean = False) _
As Boolean

Dim bexists As Boolean
Dim stempfolderpath As String
Dim inextbackwardsslash As Integer
Dim icount As Integer

On Error GoTo AnError

sFolderPath = Folder_LineAdd(sFolderPath)
stempfolderpath = sFolderPath
inextbackwardsslash = InStr(stempfolderpath, "\")
Do While (inextbackwardsslash <= Len(sFolderPath))
stempfolderpath = Left(sFolderPath, inextbackwardsslash)
If Folder_Exists(stempfolderpath) = False Then
MkDir stempfolderpath
If bInformUser = True Then
Call MsgBox( _
"The Folder already exists: " & vbCrLf & _
"'" & stempfolderpath & "'")
End If
If (inextbackwardsslash = Len(sFolderPath)) Then Exit Function
End If
If (sFolderPath = stempfolderpath) Then Exit Do
inextbackwardsslash = inextbackwardsslash + _
InStr(Right(sFolderPath, _
Len(sFolderPath) - inextbackwardsslash), "\")

Loop
If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
Call Error_Handle("Folder_Create", msMODULENAME, _
"create the folder" & vbCrLf & sFolderPath & _
vbCrLf & vbCrLf & "There may be an invalid character.")
End Function

Folder_CreateFSO

Public Function Folder_CreateFSO( _
ByVal sFolderPath As String, _
Optional ByVal bInformUser As Boolean = False)

Dim objFSOObject As Scripting.FileSystemObject

On Error GoTo ErrorHandler

Set objFSOObject = New Scripting.FileSystemObject

'make sure folder ends in "\"
' If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"

If objFSOObject.FolderExists(sFolderPath) = False Then

If bInformUser = True Then
Call MsgBox("The following folder does not exist and will be created:" & _
vbCrLf & vbCrLf & sFolderPath, vbCritical, _
"Title")
End If

'remove any folder line from the end
If Right(sFolderPath, 1) = "\" Then sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)

Call Folder_Create(Left(sFolderPath, Len(sFolderPath) - InStr(StrReverse(sFolderPath), "\")))
objFSOObject.CreateFolder (sFolderPath & "\")
End If

Set objFSOObject = Nothing
Exit Function

ErrorHandler:
Set objFSOObject = Nothing
Call Error_Handle(Err.Number & " " & Err.Description, "Folder_Create")
End Function

Folder_Delete

Removes a folder. Do we have to delete the files in the first folder. Prompt to confirm you want to delete the files as well ??.
Public Function Folder_FolderDelete( _
ByVal sAllSubFolders As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) _
As String

Dim inextcharpos As Integer

On Error GoTo ErrorHandler

If Len(sAllSubFolders) > 0 Then
inextcharpos = InStr(1, sAllSubFolders, sSeperateChar)
Folder_SubFolderRemove = Right(sAllSubFolders, Len(sAllSubFolders) - inextcharpos)
Else
Folder_SubFolderRemove = ""
If bInformUser = True Then
Call MsgBox( _
"There are no more subfolders to remove")
End If
End If

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_FolderDelete", msMODULENAME, 1,
"remove the folder and all its subfolders " & sAllSubFolders & _
" from the concatenated string")
End Function

Folder_Exists

Public Function Folder_Exists( _
ByVal sFolderPath As String) _
As Boolean

Dim iTemp As Integer

On Error GoTo AnError

iTemp = GetAttr(sFolderPath)
Folder_Exists = True

Exit Function
AnError:
Folder_Exists = False
End Function

Folder_ExistsFSO

Public Function Folder_ExistsFSO( _
ByVal sFolderPath As String) _
As Boolean

On Error GoTo ErrorHandler


Exit Function
ErrorHandler:
Folder_ExistsFSO = False
End Function

Folder_FilesNoOf

Returns the number of files in a folder with a particular extension.
Public Function Folder_FilesNoOf( _
ByVal sFolderPath As String, _
ByVal sExtension As String) _
As Long

Dim lnooffiles As Long
Dim snextfile As String

On Error GoTo AnError
lnooffiles = 0
sFolderPath = Folder_LineAdd(sFolderPath)
snextfile = Dir(sFolderPath & "\*" & sExtension)
Do Until snextfile = ""
lnooffiles = lnooffiles + 1
snextfile = Dir()
Loop
Folder_FilesNoOf = lnooffiles

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Folder_FilesNoOf", msMODULENAME, 1, _
"return the total number of files with the extension '" & sExtension & "'" & _
" in the folder path" & vbCrLf & sFolderPath)
End Function

Folder_FilesToArrayMulti

Transfers all the files in a folder with a particular extension to a multi dimensional array.
Public Sub Folder_FilesToArrayMulti( _
ByVal sFolderPath As String, _
ByVal sExtension As String, _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal bInformUser As Boolean = True)

Dim itotalfiles As Integer
Dim ifilenumber As Integer
Dim snextfile As String

On Error GoTo AnError
itotalfiles = Folder_NoOfFiles(sFolderPath, sExtension)
If itotalfiles = 0 Then
If bInformUser = True Then
Call MsgBox( _
"There are no files with extension " & _
"""" & sExtension & """ in this folder !")
End If
vArrayName = Empty
Else
snextfile = Dir(sFolderPath & "*" & sExtension)
ifilenumber = 1
ReDim vArrayName(1,itotalfiles)
Do While snextfile <> ""
vArrayName(1,ifilenumber) = snextfile
snextfile = Dir()
ifilenumber = ifilenumber + 1
Loop
End If
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Folder_FilesToArrayMulti", msMODULENAME, 1,
"transfer the list of all the files with the extension """ & sExtension & _
""" in the folder path" & vbCrLf & sFolderPath & _
"to the multi dimensional array """ & sArrayName & """")
End Sub

Folder_FilesToArraySingle1

Transfers all the files in a folder with a particular extension to a single dimensional array What is the difference between this and the above ?????.
Public Sub Folder_FilesToArraySingle( _
ByVal sFolderPath As String, _
ByVal sExtension As String, _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
Optional ByVal bInformUser As Boolean = True)

Dim itotalfiles As Integer
Dim ifilenumber As Integer
Dim snextfile As String

On Error GoTo AnError
itotalfiles = Folder_NoOfFiles(sFolderPath, sExtension)
If itotalfiles = 0 Then
If bInformUser = True Then
Call MsgBox( _
"There are no files with extension " & _
"""" & sExtension & """ in this folder !")
End If
vArrayName = Empty
Else
snextfile = Dir(sFolderPath & "*" & sExtension)
ifilenumber = 1
ReDim vArrayName(itotalfiles)
Do While snextfile <> ""
vArrayName(ifilenumber) = snextfile
snextfile = Dir()
ifilenumber = ifilenumber + 1
Loop
End If

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Folder_FilesToArraySingle", msMODULENAME, 1, _
"transfer the list of all the files with the extension """ & sExtension & _
""" in the folder path" & vbCrLf & sFolderPath & _
"to the single dimensional array """ & sArrayName & """")
End Sub

Folder_FilesToListBox

Public Sub Folder_FilesToListBox( _
ByVal sFolderPath As String, _
ByVal sExtension As String, _
ByVal lstBoxName As Control, _
Optional ByVal bInformUser As Boolean = True, _
Optional ByVal bSort As Boolean = True)

Dim vArrayName As Variant
Dim iarraycount As Integer

On Error GoTo AnError
If Folder_Valid(sFolderPath) = False Then Exit Sub
Call Folder_FilesToArraySingle(sFolderPath, sExtension, "", vArrayName, bInformUser)
If Array_Check(vArrayName) = True Then
lstBoxName.AddItem ""
For iarraycount = 0 To UBound(vArrayName)
lstBoxName.AddItem vArrayName(iarraycount)
Next iarraycount
End If

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Folder_FilesToListBox", msMODULENAME, 1, _
"transfer the list of all the files with the extension '" & sExtension & "'" & _
" in the folder path" & vbCrLf & sFolderPath & _
"to the listbox '" & lstBoxName.Name & "'.")
End Sub

Folder_FilesToListComboBox2

Transfers all the files in a folder with a particular extension to a listbox or combobox.
Public Sub Folder_FilesToListCombo( _
ByVal sFolderPath As String, _
ByVal lstBoxName As Control, _
Optional ByVal bInformUser As Boolean = True)

Dim oFolder As Scripting.Folder
Dim oFolder1 As Scripting.Folder
Dim itotalfiles As Integer
Dim ifilenumber As Integer
Dim snextfile As String

On Error GoTo AnError

Set oFolder = objFilesys.GetFolder(sFolderPath)

For Each oFolder1 In oFolder.SubFolders
lstBoxName.AddItem oFolder1.Name
Next oFolder1

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Folder_FilesToListCombo", msMODULENAME, 1, _
"transfer the list of sub folders to " & _
""" to the list box " & vbCrLf & sFolderPath)
End Sub

Folder_FilesToStr

Transfers all the files with a particular extension in a folder to a string concatenation.
Public Function Folder_FilesToStr( _
ByVal sFolderPath As String, _
ByVal sExtension As String, _
Optional ByVal sSeperateChar As String = ";") _
As String

Dim sconfiles As String
Dim sfile As String

On Error GoTo AnError
sconfiles = ""
sfile = File_GetFirst(sFolderPath, sExtension)
Do While Len(sfile) > 0
sconfiles = sconfiles & sSeperateChar & sfile
sfile = File_GetNext(sfile)
Loop
If Len(sconfiles) > 1 Then Folder_ToStr = Right(sconfiles, Len(sconfiles) - 1)

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Folder_ToStr", msMODULENAME, 1, _
"transfer the list of all the files with the extension """ & sExtension & """" & _
" in the folder """ & sFolderPath & vbCrlf " to a string concatenation")
End Function

Folder_FilesToTextFile

Transfers all the files with a particular extension to a textfile.
Public Sub Folder_ToTextFile()
On Error GoTo AnError

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Folder_ToTextFile", msMODULENAME, 1, _
"")
End Sub

Folder_FolderGetFirst

Returns the first sub folder within a folder.
Public Function Folder_FolderGetFirst( _
ByVal sFolderPath As String, _
Optional ByVal bInformUser As Boolean = False) _
As String

Dim snextitem As String
Dim larraycounter As Long

On Error GoTo AnError
Folder_SubFolderGetFirst = ""
snextitem = Dir(sFolderPath, vbDirectory)
Do While snextitem <> ""
If (snextitem <> ".") And (snextitem <> "..") And _
(GetAttr(sFolderPath & snextitem) = vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory) Then
Folder_SubFolderGetFirst = Folder_LineAdd(sFolderPath & snextitem)
Exit Function
End If
snextitem = File_GetNext(snextitem, sFolderPath)
Loop

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Folder_FolderGetFirst", msMODULENAME, 1,
"return the first sub folder from the folder path" & vbCrLf & sFolderPath)
End Function

Folder_FolderGetNext

Returns the next sub folder within a folder. If there are no subfolders then an empty string is returned ' SHOULD USE Str_GetNext.
Public Function Folder_FolderGetNext( _
ByVal sAllSubFolders As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) _
As String

Dim inextcharpos As Integer

On Error GoTo AnError
If sAllSubFolders <> "" Then
inextcharpos = InStr(sAllSubFolders, sSeperateChar)
If inextcharpos > -1 Then
Folder_SubFolderGet = Left(sAllSubFolders, inextcharpos - 1)
Else
Folder_SubFolderGet = sAllSubFolders
sAllSubFolders = ""
End If
Else
Folder_SubFolderGet = ""
If bInformUser = True Then
Call MsgBox( _
"There are no more subfolders to get")
End If
End If

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Folder_FolderGetNext", msMODULENAME, 1, _
"return the next folder from the concatenated string")
End Function

Folder_FolderRemoveFile

Public Function Folder_FolderRemoveFile( _
ByVal sFolderPath As String) _
As String

On Error GoTo ErrorHandler

Folder_FolderRemoveFile = Folder_FolderRemoveLast(sFolderPath)

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_FolderRemoveLast", msMODULENAME, 1, _
"remove the file from the end of the folder.")
End Function

Folder_FolderRemoveLast

Public Function Folder_FolderRemoveLast( _
ByVal sFolderPath As String) _
As String

Dim ichar As Integer
Dim sremaining As String

On Error GoTo ErrorHandler

sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)
If Right(sFolderPath, 1) = ":" Then
Folders_FolderRemoveLast = ""
Exit Function
End If
ichar = InStr(1, sFolderPath, "\")
Do While ichar > 0
sremaining = sremaining & Left(sFolderPath, ichar)
sFolderPath = Right(sFolderPath, Len(sFolderPath) - ichar)
ichar = InStr(1, sFolderPath, "\")
Loop
Folders_FolderRemoveLast = sremaining

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folders_FolderRemoveLast", msMODULENAME, 1, _
"remove the last item from the folder.")
End Function

Folder_FoldersAllToString

Returns a string concatenation of all the immediate sub folders within a given folder.
Public Function Folder_FoldersAllToString( _
ByVal sFolderPath As String, _
Optional ByVal sSeparateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) _
As String

Dim smainfolders As String
Dim smainfolderstemp As String
Dim ssubfolders As String
Dim ssubfolderstemp As String
Dim inextcharpos As Integer

On Error GoTo ErrorHandler

If Folder_Exists(sFolderPath, bInformUser) = True Then
smainfolders = ""
If Folder_SubFoldersAny(sFolderPath, bInformUser) = True Then _
smainfolders = Folder_SubFoldersGetAll(sFolderPath, sSeparateChar, bInformUser)
smainfolderstemp = smainfolders
Do While smainfolderstemp <> ""
inextcharpos = Str_FindPositionofNextChar(smainfolderstemp, 1, sSeparateChar)
If inextcharpos > -1 Then
ssubfolders = Left(smainfolderstemp, inextcharpos - 1)
smainfolderstemp = _
Right(smainfolderstemp, Len(smainfolderstemp) - Len(ssubfolders) - 1)
Else
ssubfolders = smainfolderstemp
smainfolderstemp = ""
End If
ssubfolderstemp = Folder_SubFoldersAll(ssubfolders, sSeparateChar, bInformUser)
If ssubfolderstemp <> "" Then _
smainfolders = smainfolders & sSeparateChar & ssubfolderstemp
Loop
Else: Folder_SubFoldersAll = ""
End If
Folder_SubFoldersAll = smainfolders

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_FoldersAllToString", msMODULENAME, 1,
"get all the immediate folders contained within the folder path" & vbCrLf & _
sFolderPath & vbCrLf & "and concatenate them all into a string")
End Function

Folder_FoldersAny

Determines if a folder has any subfolders. Returns True or False.
Public Function Folder_FoldersAny( _
ByVal sFolderPath As String, _
Optional ByVal bCheckLineAdd As Boolean = False, _
Optional ByVal bInformUser As Boolean = True) As Boolean

Dim snextitem As String
Dim larraycounter As Long

On Error GoTo ErrorHandler

If bCheckLineAdd = True Then sFolderPath = Folder_LineAdd(sFolderPath)
Folder_AnySubFolders = False
snextitem = Dir(sFolderPath, vbDirectory)
Do While Len(snextitem) > 0
If (snextitem <> ".") And (snextitem <> "..") And _
(GetAttr(sFolderPath & snextitem) = vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory + vbReadOnly) Then

Exit Do
End If
snextitem = File_GetNext(snextitem, sFolderPath)
Loop
If Len(snextitem) = 0 Then Folder_FoldersAny = False
If Len(snextitem) > 0 Then Folder_FoldersAny = True

If gbDEBUG = False Then Exit Function
ErrorHandler:
If bInformUser = True Then
Call MsgBox( _
"Access is denied to the folder path """ & sFolderPath & """")
Folder_FoldersAny = False
Exit Function
End If

Call Error_Handle("Folder_FoldersAny", msMODULENAME, 1, _
"determine if the folder path" & vbCrLf & sFolderPath & vbCrLf & _
"has any subfolders")
End Function

Folder_FoldersGetAllToString

Returns a string concatenation of all the subfolders (at all levels) within a given folder.
Public Function Folder_FoldersGetAllToString( _
ByVal sFolderPath As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) _
As String

Dim ssubfolders As String
Dim snextitem As String
Dim larraycounter As Long

On Error GoTo ErrorHandler

ssubfolders = ""
snextitem = Folder_SubFolderGetFirst(sFolderPath)
If snextitem = "" Then
If bInformUser = True Then
' Call Frm_Inform("",
Call Msgbox ( _
"There are no sub folders in the folder " & _
"""" & sFolderPath & """")
End If
Else
ssubfolders = snextitem
snextitem = File_GetNext(snextitem, sFolderPath)
End If
Do While (snextitem <> "")
If (snextitem <> ".") And (snextitem <> "..") And _
(GetAttr(sFolderPath & snextitem) = vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory) Then
ssubfolders = ssubfolders & sSeperateChar & Folder_LineAdd(sFolderPath & snextitem)
End If
snextitem = File_GetNext(snextitem, sFolderPath)
Loop
Folder_SubFoldersGetAll = ssubfolders

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_FoldersGetAllToString", msMODULENAME, 1, _
"get all the folders (inc. subfolders) contained within the folder path" & _
vbCrLf & sFolderPath & vbCrLf & "and concatenate them all into a string")
End Function

Folder_FoldersHasAny

Public Function Folder_FoldersHasAny( _
ByVal sFolderPath As String, _
Optional ByVal bCheckLineAdd As Boolean = False, _
Optional ByVal bInformUser As Boolean = True) _
As Boolean

Dim lnooffiles As Long
Dim snextitem As String

On Error GoTo ErrorHandler

lnooffiles = 0
If bCheckLineAdd = True Then sFolderPath = Folder_LineAdd(sFolderPath)
snextitem = Dir(sFolderPath, vbDirectory)
Do Until (snextitem = "")
If (snextitem <> ".") And (snextitem <> "..") And _
(GetAttr(sFolderPath & snextitem) = vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory + vbReadOnly) Then
Exit Do
End If
snextitem = Dir()
Loop
If Len(snextitem) = 0 Then Folder_FoldersHasAny = False
If Len(snextitem) > 0 Then Folder_FoldersHasAny = True

If gbDEBUG = False Then Exit Function
ErrorHandler:
If bInformUser = True Then
Call MsgBox( _
"Access is denied to the folder path """ & sFolderPath & """")
Folder_FoldersHasAny = False
Exit Function
End If
Call Error_Handle("Folder_FoldersHasAny", msMODULENAME, 1, _
"determine if there are any sub folders in the folder path" & _
vbCrLf & sFolderPath)
End Function

Folder_FoldersNoOf

Returns the number of immediate sub folders contained within a folder.
Public Function Folder_FoldersNoOf( _
ByVal sFolderPath As String) _
As Long

Dim lnooffolders As Long
Dim snextitem As String

On Error GoTo ErrorHandler

lnooffolders = 0
sFolderPath = Folder_LineAdd(sFolderPath)
snextitem = Dir(sFolderPath, vbDirectory)
Do Until Len(snextitem) = 0
If (snextitem <> ".") And (snextitem <> "..") And _
(GetAttr(sFolderPath & snextitem) = vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory + vbReadOnly) Then
lnooffolders = lnooffolders + 1
End If
snextitem = Dir(, vbDirectory)
Loop
Folder_FoldersNoOf = lnooffolders

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_FoldersNoOf", msMODULENAME, sPROCNAME, 1, _
"return the total number of sub folders" & _
" in the folder path" & vbCrLf & sFolderPath)
End Function

Folder_FoldersToComboBox

Public Sub Folder_FoldersToComboBox( _
ByVal sFolderPath As String, _
ByRef cboBoxName As Control, _
Optional ByVal bInformUser As Boolean = False, _
Optional ByVal bSort As Boolean = True, _
Optional ByVal bAddThreeDots As Boolean = False)

Dim vArrayName As Variant

On Error GoTo ErrorHandler

Call Folder_FoldersToArraySingle(sFolderPath, "", vArrayName, bInformUser, bAddThreeDots)
If Array_Check(vArrayName, False) = True Then
cboBoxName.List = vArrayName
Else
cboBoxName.Clear
End If

If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle("Folder_FoldersToComboBox", msMODULENAME, 1, _
"transfer the list of all the folders" & _
" in the folder path" & vbCrLf & sFolderPath & _
"to the combobox '" & cboBoxName.Name & "'.")
End Sub

Folder_FoldersToListBox

Public Sub Folder_FoldersToListBox( _
ByVal sFolderPath As String, _
ByVal lstBoxName As Control, _
Optional ByVal bInformUser As Boolean = False, _
Optional ByVal bSort As Boolean = True, _
Optional ByVal bAddThreeDots As Boolean = False)

Dim vArrayName As Variant

On Error GoTo ErrorHandler

Call Folder_FoldersToArraySingle(sFolderPath, "", vArrayName, bInformUser, bAddThreeDots)
If Array_Check(vArrayName, False) = True Then
lstBoxName.List = vArrayName
Else
lstBoxName.Clear
End If

If gbDEBUG = False Then Exit Sub
ErrorHandler:
Call Error_Handle("Folder_FoldersToListBox", msMODULENAME, 1, _
"transfer the list of all the sub folders" & _
" in the folder path" & vbCrLf & sFolderPath & _
"to the listbox '" & lstBoxName.Name & "'.")
End Sub

Folder_FoldersToString

Transfers all the sub folders in a particular folder with a given extension to a string concatenation.
Public Function Folder_FoldersToString()

On Error GoTo ErrorHandler

Folder_FoldersToString = ""

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_FoldersToString", msMODULENAME, 1, _
"")
End Sub

Folder_LineAdd

Public Function Folder_LineAdd( _
ByVal sFolderPath As String) As String

Const sPROCNAME As String = "Folder_LineAdd"
Dim balter As Boolean

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

If sFolderPath <> "" Then
balter = False
If Right(sFolderPath, 1) <> "\" Then
balter = True
End If
If balter = True Then Folder_LineAdd = sFolderPath & "\"
If balter = False Then Folder_LineAdd = sFolderPath
Else
Folder_LineAdd = ""
End If

If g_bDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Folder_PathRemove

Public Function Folder_PathRemove( _
ByVal sFolderPath As String, _
Optional ByVal bRemoveExtension As Boolean = False) _
As String

Dim icharpos As Integer
Dim stemp As String

On Error GoTo ErrorHandler

If sFolderPath <> "" Then
icharpos = InStrRev(sFolderPath, "\")

stemp = Right(sFolderPath, Len(sFolderPath) - icharpos)

If bRemoveExtension = True Then
stemp = Left(stemp, Len(stemp) - 4)
End If
Folder_PathRemove = stemp

Else
Folder_PathRemove = ""
End If

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("Folder_PathRemove", msMODULENAME, 1, _
"return just the file from the full folder path" & _
vbCrLf & sFolderPath)
End Function

Folder_Valid

Public Function Folder_Valid( _
ByVal sFolderPath As String) _
As Boolean

On Error GoTo ErrorHandler

If Dir(sFolderPath, vbDirectory) = "" Then
End If
Folder_Valid = True

Exit Function
ErrorHandler:
Folder_Valid = False
End Function

Folders_ToArraySingle

Transfers all the sub folders in a particular folder with a given extension to a single dimensional array.
Public Sub Folder_FoldersToArraySingle(ByVal sFolderPath As String, _
ByVal sArrayName As String, _
ByRef vArrayName As Variant, _
Optional ByVal bInformUser As Boolean = True, _
Optional ByVal bAddThreeDots As Boolean = False)

Dim itotalfiles As Integer
Dim ifoldernumber As Integer
Dim snextitem As String

On Error GoTo AnError
If Folder_FoldersHasAny(sFolderPath, False) = True Then
ifoldernumber = 0
snextitem = Dir(sFolderPath, vbDirectory)
ReDim vArrayName(10000)
If bAddThreeDots = True Then
vArrayName(ifoldernumber) = "[...]"
ifoldernumber = ifoldernumber + 1
End If
Do Until snextitem = ""
If (snextitem <> ".") And (snextitem <> "..") And _
(GetAttr(sFolderPath & snextitem) = vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory Or _
GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory + vbReadOnly) Then
vArrayName(ifoldernumber) = snextitem
ifoldernumber = ifoldernumber + 1
End If
snextitem = Dir(, vbDirectory)
Loop
ReDim Preserve vArrayName(ifoldernumber - 1)
Else
vArrayName = Empty
If bAddThreeDots = True Then
ReDim vArrayName(0)
vArrayName(0) = "[...]"
ifoldernumber = ifoldernumber + 1
End If
If bInformUser = True Then
Call MsgBox("There are no folders in this folder !")
End If
End If

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Folder_FoldersToArraySingle", msMODULENAME, 1, _
"transfer the list of all the files with the extension '" & _
"' in the folder path" & vbCrLf & sFolderPath & _
"to the single dimensional array '" & sArrayName & "'")
End Sub

Message_FileDoesNotExist

Public Sub Message_FileDoesNotExist( _
ByVal sFolderPath As String, _
ByVal sFileName As String)

Dim sMessage As String
sMessage = "This file does not exist: " & vbCrLf & vbCrLf & "'" & sFolderPath & sFileName & "'"
Call MsgBox(sMessage, vbOKOnly + vbInformation, modConstants.g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "File Missing")
Call Tracer_Add("MESSAGE", sMessage)
End Sub

Message_FolderDoesNotExist

Public Sub Message_FolderDoesNotExist( _
ByVal sFolderPath As String)

Dim sMessage As String
sMessage = "This folder path does not exist: " & vbCrLf & vbCrLf & "'" & sFolderPath & "'"
Call MsgBox(sMessage, vbOKOnly + vbInformation, modConstants.g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Folder Missing")
Call Tracer_Add("MESSAGE", sMessage)
End Sub

Message_FolderPathEmpty

Public Sub Message_FolderPathEmpty( _
ByVal sFolderPath As String)

Dim sMessage As String
sMessage = "This folder path is empty: " & vbCrLf & vbCrLf & "'" & sFolderPath & "'"
Call MsgBox(sMessage, vbOKOnly + vbInformation, modConstants.g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Folder Path Empty")
Call Tracer_Add("MESSAGE", sMessage)
End Sub

TextFile_Add

Adds text to an existing text file.
Public Sub TextFile_Add(ByVal sText As String, _
ByVal iFileNo As Integer)

On Error GoTo AnError
Print #iFileNo, sText

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("TextFile_Add", msMODULENAME, 1, _
"")
End Sub

TextFile_Close

Closes a text file from being read or written to.
Public Sub TextFile_Close(ByVal iFileNo As Integer)

On Error GoTo AnError
Close #iFileNo

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("TextFile_Close", msMODULENAME, sPROCNAME, 1, _
"close the text file !")
End Sub

TextFile_GetContents

Returns the full contents a text file.
Public Function TextFile_GetContents( _
ByVal iFileNo As Integer) _
As String

Dim seachline As String
Dim swholefile As String

On Error GoTo ErrorHandler

Do While Not EOF(iFileNo)
Line Input #iFileNo, seachline
swholefile = swholefile & vbCrLf & seachline
Loop
TextFile_GetContents = swholefile

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("TextFile_GetContents", msMODULENAME, 1, _
"")
End Function

TextFile_GetEntire

What is the difference between this and the one above.
Public Function TextFile_GetEntire( _
ByVal iFileNo As Integer) _
As String

On Error GoTo AnError

'since InputB function returns an ANSI string need to convert it
TextFile_GetEntire = StrConv(InputB(LOF(iFileNo), iFileNo), vbUnicode)

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("TextFile_GetEntire", msMODULENAME, 1, _
"")
End Function

TextFile_GetLinesAfter

Returns all the text in a text file after it finds the first occurrence of a text string.
Public Function TextFile_GetLinesAfter( _
ByVal iFileNo As Integer, _
ByVal sSearchText As String) _
As String

Dim seachline As String
Dim swholefile As String

On Error GoTo AnError
Do While Not EOF(iFileNo)
Line Input #iFileNo, seachline
If InStr(1, seachline, sSearchText) > 0 Then swholefile = ""
swholefile = swholefile & vbCrLf & seachline
Loop
TextFile_GetLinesAfter = swholefile

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("TextFile_GetLinesAfter", msMODULENAME, 1, _
"")
End Function

TextFile_Open

Creates or opens a text file for reading or writing.
Public Function TextFile_Open(ByVal sMethod As String, _
ByVal sFolderPath As String, _
ByVal sFileName As String, _
Optional ByVal sExtension As String = ".txt", _
Optional ByVal iRecordLength As Integer) _
As Integer

Dim ifilenumber As Integer

On Error GoTo AnError
ifilenumber = FreeFile 'obtains the next available file number
If sMethod = "Seq_Read" Then _
Open sFolderPath & sFileName & sExtension For Input As #ifilenumber
If sMethod = "Seq_Write" Then _
Open sFolderPath & sFileName & sExtension For Output As #ifilenumber

' If sMethod = "Bin_Read" Then _
' Open sFolderPath & sFileName & sExtension For Binary Access Write As #ifilenumber
' If sMethod = "Bin_Write" Then _
' Open sFolderPath & sFileName & sExtension For Binary Access Write As #ifilenumber
'
' If sMethod = "Random_Read" Then _
' Open sFolderPath & sFileName & sExtension For Random As #ifilenumber Len = iRecordLength
' If sMethod = "Random_Write" Then _
' Open sFolderPath & sFileName & sExtension For Random As #ifilenumber Len = iRecordLength

TextFile_Open = ifilenumber

If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("TextFile_Open", msMODULENAME, 1, _
"open the file:" & _
vbCrLf & """" & sFolderPath & sFileName & sExtension & """" & _
vbCrLf & "and return the corresponding file number")
End Function

TextFile_ToArrayMulti

Transfers the contents of a text file to a multi dimensional array.
Public Function TextFile_ToArrayMulti( _
ByVal sArrayName As String, _
ByVal vArrayName As Variant, _
ByVal sFolderPath As String, _
ByVal iNoOfCols As Integer, _
ByVal sTextFile As String, _
Optional ByVal sExtension As String = ".txt", _
Optional ByVal bBlankLine As Boolean = True) _
As Integer

Dim iFileNo As Integer
Dim lNoOfRecords As Long
Dim lReadRecords As Long
Dim icolcount As Integer

On Error GoTo ErrorHandler

iFileNo = FreeFile
sTextFile = sFolderPath & sTextFile & sExtension
Open sTextFile For Input As #iFileNo
lNoOfRecords = 0
While Not EOF(iFileNo)
Line Input #iFileNo, sReadLine
lNoOfRecords = lNoOfRecords + 1
Wend
Close #iFileNo
If lNoOfRecords = 0 Then TextFile_ToArray = 0
If lNoOfRecords = 0 Then Exit Function
If lNoOfRecords > 0 Then
ReDim vArrayName(iNoOfCols, lNoOfRecords)
Open sTextFile For Input As #iFileNo
lReadRecords = 1
While Not EOF(iFileNo)
For icolcount = 1 To iARRAYINTERNAL_TOTAL
Line Input #iFileNo, vArrayName(icolcount, iReadRecords + 1)
Next icolcount
If (bBlankLine = True) And (iNoOfRecords > iReadRecords) Then _
Line Input #iFileNo, sBlankLine
iReadRecords = iReadRecords + 1
Wend
TextFile_ToArray = iReadRecords
End If

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("TextFile_ToArrayMulti", msMODULENAME, 1, _
"read all the information from the text file" & _
vbCrLf & sERRORMESSAGE, vbCritical, "AddressBook_Read")
End Function

TextFile_ToArraySingle

Transfers the contents of a text file to a single dimensional array.
Public Sub TextFile_ToArraySingle()

On Error GoTo AnError

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("TextFile_ToArraySingle", msMODULENAME, 1, _
"")
End Sub

TextFile_ToListComboBox

Transfers the contents of a text file to a listbox or combobox.
Public Sub TextFile_ToListComboBox()

On Error GoTo AnError

If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("TextFile_ToListComboBox", msMODULENAME, 1, _
"")
End Sub

TextFile_ToStringFSO

Transfers the contents of a text file to a string concatenation.
Public Function TextFile_ToStringFSO( _
ByVal sFolderPath As String, _
ByVal sTextFileName As String, _
Optional ByVal sExtension As String = ".txt", _
Optional ByVal sSeparateChar As String = "#", _
Optional ByVal bInformUser As Boolean = True, _
Optional ByVal lNoOfLinesMax As Long = 50) _
As String

Const sPROCNAME As String = "TextFile_ToStringFSO"

Dim objFSO As Scripting.FileSystemObject
Dim scrText As Scripting.TextStream
Dim arlines() As String
Dim llineno As Long
Dim slineoftext As String
Dim stotalcontents As String
Dim vacontents As Variant
Dim lnooflines As Long

On Error GoTo ErrorHandler
Call Tracer_AddSubroutineStart(msMODULENAME, sPROCNAME)

Set objFSO = New FileSystemObject
If objFSO.FileExists(sFolderPath & sTextFileName & sExtension) = True Then
Set scrText = objFSO.OpenTextFile(sFolderPath & sTextFileName & sExtension, IOMode.ForReading)
Else
If bInformUser = True Then
Call MsgBox("This file does not exist - unable to return the contents.")
Exit Function
End If
End If
stotalcontents = ""
If (lNoOfLinesMax > -1) Then
arlines = VBA.Split(scrText.ReadAll, vbCrLf)
If (lNoOfLinesMax < UBound(arlines)) Then
For llineno = (UBound(arlines) - lNoOfLinesMax) To UBound(arlines)
stotalcontents = stotalcontents & arlines(llineno) & sSeparateChar
Next llineno
Else
For llineno = 0 To UBound(arlines)
stotalcontents = stotalcontents & arlines(llineno) & sSeparateChar
Next llineno
End If
Else
lnooflines = 1
Do While Not scrText.AtEndOfStream
slineoftext = scrText.ReadLine
stotalcontents = stotalcontents & slineoftext & sSeparateChar
lnooflines = lnooflines + 1
If (lNoOfLinesMax <> -1) And (lnooflines > lNoOfLinesMax) Then
Exit Do
End If
Loop
End If
TextFile_ToStringFSO = stotalcontents
scrText.Close
Set scrText = Nothing
Set objFSO = Nothing

Exit Function
ErrorHandler:
scrText.Close
Set scrText = Nothing
Set objFSO = Nothing
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"read all the information from the text file" & vbCrLf & _
"'" & sFolderPath & sTextFileName & sExtension & "'" & vbCrLf & _
"and return it as a string concatenation")
End Function

TextFile_Write

Writes / adds text to a text file.
Public Function TextFile_Write( _
ByVal sMethod As String, _
ByVal sFolderPath As String, _
ByVal sFileName As String, _
ByVal sTextToAdd As String, _
Optional ByVal bReplaceAll As Boolean) _
As String

Dim ifilenumber As Integer
Dim swholefile As String

On Error GoTo ErrorHandler

swholefile = ""
If (bReplaceAll = False) Then
ifilenumber = TextFile_Open("Seq_Read", sFolderPath, sFileName)
swholefile = TextFile_GetEntire(ifilenumber)
MsgBox swholefile
Close #ifilenumber
End If

ifilenumber = TextFile_Open("Seq_Write", sFolderPath, sFileName)

If (sMethod = "Seq") Then
Print #ifilenumber, swholefile & sTextToAdd
End If

Close #ifilenumber

If gbDEBUG = False Then Exit Function
ErrorHandler:
Call Error_Handle("TextFile_Write", msMODULENAME, 1, _
"add the text" & vbCrLf & """" & sTextToAdd & """" & vbCrLf & "to the >>>")
End Function

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top