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 ErrorHandler

   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
 
ErrorHandler:
   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 fso As New Scripting.FileSystemObject 
Dim sreturn As String

   On Error GoTo ErrorHandler

   File_Exists = fso.FileExists(sFileName) 
   Set fso = Nothing 

   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 ErrorHandler

   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
ErrorHandler:
   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 ErrorHandler

   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
ErrorHandler:
   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 ErrorHandler

   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
ErrorHandler:
   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 ErrorHandler
   snextfilename = Dir()
   If (File_GetNext <> sCurrentFileName) Then 
      File_GetNext = snextfilename
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   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 ErrorHandler
   File_DateLastModified = Left(FileDateTime(sFolderPath & sFileName & sExtension), 10)
 
   If gbDEBUG = False Then Exit Function
ErrorHandler:
   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 ErrorHandler

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

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   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
Const sPROCNAME As String = "Folder_Browse"

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

Const sPROCNAME As String = "Folder_CanAccessFSO"

Dim objFSOObject As Scripting.FileSystemObject
   On Error GoTo ErrorHandler
  
   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

ErrorHandler:
   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_CopyFSO

The VBA alternative would need to verify that the folder existed and then loop through all the files in that folder, copying each, one at a time.

Public Function Folder_CopyFSO(ByVal source As String, _ 
                               ByVal destination As String) 

Dim fso As New Scripting.FileSystemObject 
   On Error GoTo ErrorHandler 

   fso.CopyFolder source, destination 
   Set fso = Nothing
   Exit Sub
ErrorHandler:

Exit 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

Const sPROCNAME As String = "Folder_Create"
Dim bexists As Boolean
Dim stempfolderpath As String
Dim inextbackwardsslash As Integer
Dim icount As Integer

   On Error GoTo ErrorHandler
   
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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)

Const sPROCNAME As String = "Folder_CreateFSO"
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(msMODULENAME, sPROCNAME, _
        Err.Number & " " & Err.Description)
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_Delete( _
         ByVal sAllSubFolders As String, _
Optional ByVal sSeperateChar As String = ";", _
Optional ByVal bInformUser As Boolean = False) _
         As String

Const sPROCNAME As String = "Folder_Delete"
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(msMODULENAME, sPROCNAME, _
        "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 ErrorHandler
   
   iTemp = GetAttr(sFolderPath)
   Folder_Exists = True
   
   Exit Function
ErrorHandler:
   Folder_Exists = False
End Function

Public Function Folder_Exists(sFolderPath As String, _
                              Optional bInformUser As Boolean = False) As Boolean
Const PROCNAME As String = "Folder_Exists"
'DirExists = (GetAttr(sDirName) And vbDirectory) = vbDirectory

   If Dir(sFolderPath, vbDirectory) = "" Then
      Folder_Exists = False
      If bInformUser = True Then _
         Call MsgBox("The File or Folder does not exists : " & vbCrLf & _
                     """" & sFolderPath & """")
   Else
      Folder_Exists = True
   End If
   Exit Function
AnError:
'   Call Error_Handle(msMODULENAME, PROCNAME, 2, "FD7", "NO")
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

Const sPROCNAME As String = "Folder_FilesNoOf"
Dim lnooffiles As Long
Dim snextfile As String

   On Error GoTo ErrorHandler
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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)

Const sPROCNAME As String = "Folder_FilesToArrayMulti"
Dim itotalfiles As Integer
Dim ifilenumber As Integer
Dim snextfile As String

   On Error GoTo ErrorHandler
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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_FilesToArraySingle

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)

Const sPROCNAME As String = "Folder_FilesToArraySingle"
Dim itotalfiles As Integer
Dim ifilenumber As Integer
Dim snextfile As String

   On Error GoTo ErrorHandler
   itotalfiles = Folder_FilesNoOf(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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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)

Const sPROCNAME As String = "Folder_FilesToListBox"
Dim vArrayName As Variant
Dim iarraycount As Integer

   On Error GoTo ErrorHandler
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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)

Const sPROCNAME As String = "Folder_FilesToListCombo"
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 ErrorHandler
   
   Set oFolder = objFilesys.GetFolder(sFolderPath)
   
   For Each oFolder1 In oFolder.SubFolders
      lstBoxName.AddItem oFolder1.Name
   Next oFolder1

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FilesToStr"
Dim sconfiles As String
Dim sfile As String

   On Error GoTo ErrorHandler
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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()

Const sPROCNAME As String = "Folder_ToTextFile"

   On Error GoTo ErrorHandler


   If gbDEBUG = False Then Exit Sub 
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "")
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

Const sPROCNAME As String = "Folder_FolderGetFirst"
Dim snextitem As String
Dim larraycounter As Long

   On Error GoTo ErrorHandler
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FolderGetNext"
Dim inextcharpos As Integer

   On Error GoTo ErrorHandler
   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
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "return the next folder from the concatenated string")
End Function

Folder_FolderRemoveFile

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

Const sPROCNAME As String = "Folder_FolderRemoveFile"

   On Error GoTo ErrorHandler

   Folder_FolderRemoveFile = Folder_FolderRemoveLast(sFolderPath)

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

Folder_FolderRemoveLast

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

Const sPROCNAME As String = "Folder_FolderRemoveLast"
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(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FoldersAllToString"
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(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FoldersAny"
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(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FoldersGetAllToString"
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(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FoldersHasAny"
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(msMODULENAME, sPROCNAME, _
        "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

Const sPROCNAME As String = "Folder_FoldersNoOf"
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(msMODULENAME, sPROCNAME, _
        "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)

Const sPROCNAME As String = "Folder_FoldersToComboBox"
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(msMODULENAME, sPROCNAME, _
        "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)

Const sPROCNAME As String = "Folder_FoldersToListBox"
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(msMODULENAME, sPROCNAME, _
        "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()

Const sPROCNAME As String = "Folder_FoldersToString"

   On Error GoTo ErrorHandler

   Folder_FoldersToString = ""

   If gbDEBUG = False Then Exit Function 
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, _
        "")
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

Const sPROCNAME As String = "Folder_PathRemove"
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(msMODULENAME, sPROCNAME, _
        "return just the file from the full folder path" & _
        vbCrLf & sFolderPath)
End Function

Folder_SubFoldersGetAll

Public Function Folder_SubFoldersGetAll(ByVal sFolderPath As String, _
                               Optional ByVal sSeperateChar As String = ";", _
                               Optional ByVal bInformUser As Boolean = False) As String

Const sPROCNAME As String = "Folder_SubFoldersGetAll"
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, sSeperateChar, bInformUser)
      smainfolderstemp = smainfolders
      Do While smainfolderstemp <> ""
         inextcharpos = Str_FindPositionofNextChar(smainfolderstemp, 1, sSeperateChar)
         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, sSeperateChar, bInformUser)
         If ssubfolderstemp <> "" Then
                            smainfolders = smainfolders & sSeperateChar & ssubfolderstemp
         End If
      Loop
   Else: Folder_SubFoldersGetAll = ""
   End If
   Folder_SubFoldersGetAll = smainfolders

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

Folder_SubFoldersHasAny

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

Const sPROCNAME As String = "Folder_SubFoldersAny"
Dim snextitem As String
Dim larraycounter As Long

   On Error GoTo ErrorHandler
   Folder_SubFoldersHasAny = False
   snextitem = Dir(sFolderPath, vbDirectory)
   Do While snextitem <> ""
      If (snextitem <> ".") And (snextitem <> "..") And _
         (GetAttr(sFolderPath & snextitem) = vbDirectory Or _
          GetAttr(sFolderPath & snextitem) = vbArchive + vbDirectory) Then
         Folder_SubFoldersHasAny = True
         Exit Function
      End If
      snextitem = File_GetNext(snextitem)
   Loop
   Exit Function
ErrorHandler:

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