VBA Snippets
File_Browse
Displays the dialog box to allow the user to browse to a file.Public Sub File_Browse()
Const sPROCNAME As String = "File_Browse"
On Error GoTo AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Sub
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
Public Sub File_Delete( _
ByVal sFolderPath As String, _
ByVal sFileName As String)
Const sPROCNAME As String = "File_Delete"
On Error GoTo AnError
If Len(Dir(sFolderPath & sFileName)) > 0 Then
SetAttr sFolderPath & sFileName, vbNormal
Kill sFolderPath & sFileName
End If
Exit Sub
AnError:
Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description, _
"")
End Sub
File_DialogFilePicker
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 !!", , "BlueBay Asset Management")
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_DialogSaveAs
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 AnError
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
AnError:
Call Error_Handle(sPROCNAME, msMODULENAME, 1, _
"display the File Save As dialog box.")
End Function
'****************************************************************************************
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 sfullpath As String
Dim sFileName As String
Dim sfolder As String
On Error GoTo AnError
sfullpath = Application.GetSaveAsFilename(sFolderPath & sDefaultFileName, _
"Microsoft Excel Workbook (*.xls), *.xls", _
, sDialogPrefix & "File Save As")
If sfullpath = "False" Then
File_SaveAsDialog = "Cancelled"
Exit Function
Else
sFileName = Folder_PathRemove(sfullpath)
sfolder = Left(sfullpath, Len(sfullpath) - Len(sFileName))
File_SaveAsDialog = Wbk_SaveAs(sfolder, sFileName, "", , True)
End If
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle(sPROCNAME, msMODULENAME, 1, _
"display the File Save As dialog box.")
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_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
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 AnError
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
AnError:
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
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 AnError
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
AnError:
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 AnError
Open sFolderPath & sFileName & sExtension For Binary Access Read Lock Read As #1
Close #1
If gbDEBUG = False Then Exit Function
AnError:
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 AnError
If gbDEBUG = False Then Exit Function
AnError:
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 AnError
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
AnError:
Call Error_Handle("File_Rename", msMODULENAME, 1,
"")
End Sub
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 AnError
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
AnError:
File_Size = 0
Call Error_Handle("File_Size", msMODULENAME, 1,
"")
FileSize = 0
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 AnError
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
AnError:
Set scrText = Nothing
Set objFSO = Nothing
End Function
File_TextWrite
Public Function File_TextWrite(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 AnError
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_TextWrite = True
Exit Function
AnError:
Set scrText = Nothing
Set objFSO = Nothing
File_TextWrite = 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
Fiolder_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 AnError
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
AnError:
Call Error_Handle("Folder_Browse", msMODULENAME, 1, _
"browse to a particular folder and return the path")
End Function
'****************************************************************************************
Public Function Folder_Browse( _
ByVal sFolderPath As String, _
ByVal sButtonCaption As String) _
As String
On Error GoTo AnError
gsResponse = sFolderPath 'to be used by the useform initilaise
Load frmFolderBrowse
frmFolderBrowse.cmbOK.Caption = sButtonCaption
frmFolderBrowse.Show
Folder_Browse = gsResponse 'should return the new browsed to folder path
gsResponse = ""
If gbDEBUG = False Then Exit Function
AnError:
Call Error_Handle("Folder_Browse", msMODULENAME, 1, _
"browse to the folder '" & sFolderPath & "'.")
End Function
Folder_CanAccess
Public Function Folder_CanAccess( _
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)
Dim objFSOObject As Scripting.FileSystemObject
On Error GoTo AnError
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
AnError:
Set objFSOObject = Nothing
Call Error_Handle(Err.Number & " " & Err.Description, "Folder_Create")
End Function
'***************************************************************************************
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_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 AnError
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
AnError:
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_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 AnError
Folder_FolderRemoveFile = Folder_FolderRemoveLast(sFolderPath)
If gbDEBUG = False Then Exit Function
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 AnError
Folder_FoldersToString = ""
If gbDEBUG = False Then Exit Function
AnError:
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 AnError
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
AnError:
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 AnError
If Dir(sFolderPath, vbDirectory) = "" Then
End If
Folder_Valid = True
Exit Function
AnError:
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 AnError
Do While Not EOF(iFileNo)
Line Input #iFileNo, seachline
swholefile = swholefile & vbCrLf & seachline
Loop
TextFile_GetContents = swholefile
If gbDEBUG = False Then Exit Function
AnError:
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 AnError
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
AnError:
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_ToString
Transfers the contents of a text file to a string concatenation.Public Function TextFile_ToString(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_ToString"
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_ToString = 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 AnError
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
Close #ifilenumber
If gbDEBUG = False Then Exit Function
AnError:
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