' Code courtesy of UtterAccess Wiki
' http://www.utteraccess.com/wiki/index.php/Category:FunctionLibrary
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
'==============================================================================
' NAME: GetDirContents
'
' PURPOSE: Retrieves lists and information about contents of a directory
'
' RETURNS: DIRECTORYCONTENTS structure
'          This procedure does not raise an error on an invalid
'          directory parameter
'
' ARGUMENTS: sDirectory - Directory to evaluate
'            Delimiter (Optional, default ";") - list delimiter for return
'
'
'
' DEPENDANCIES:
'
'  The Split() and Replace() functions are required for this procedure.  If
'  you are using Access 97 or earlier you will need custom versions of these
'  for this procedure to work.
'
'  This structure is required in the declarations section of a standard module
'  ----------
'  Public Type DIRECTORYCONTENTS
'    dcCount As Long             'number of files and directories
'    dcDirectory As Long         'number of directories
'    dcFiles As String           'delimited list of files
'    dcDirectories As String     'delimited list of directories
'    dcReadOnly As Long          'number of read only files
'    dcHidden As Long            'number of hidden files
'    dcSystem As Long            'number of system files
'    dcArchive As Long           'number of files ready for archiving
'  End Type
'  ----------
'
'  This function includes a call to QSortInPlace.  Because directory contents
'  returned from the Dir() function are not sorted, this is used to return
'  a list that is sorted.
'
'  The QSortInPlace function is property of Chip Pearson and can be found at:
'     http://www.cpearson.com/excel/SortingArrays.aspx
'
'  The QSortInPlace call can be commented out with no consequence to the return
'  of the function other than having the lists of files and directories sorted
'  by numerically and alphabetically
'
'
'
' EXAMPLE USAGE:
'  ----------
'  Sub PrintDirInfo(sDir As String)
'    Dim dc As DIRECTORYCONTENTS
'    dc = GetDirContents(sDir)
'    With dc
'      Debug.Print "Directory List: " .dcDirectories & vbCrLf
'      Debug.Print "File List: " & .dcFiles & vbCrLf
'      Debug.Print "Item Count: " & .dcCount & vbCrLf
'      Debug.Print "Number of Directories: " & .dcDirectory & vbCrLf
'      Debug.Print "Number of Read Only: " & .dcReadOnly & vbCrLf
'      Debug.Print "Number of Hidden Files :" & .dcHidden & vbCrLf
'      Debug.Print "Number of System Files: " & .dcSystem & vbCrLf
'      Debug.Print "Number of Archive Ready Files: " & .dcArchive & vbCrLf
'    End With
'  End Sub
'  ----------
'
'
' REVISIONS:
'  REV |    DATE    | REV TYPE | DESCRIPTION
'------------------------------------------------------------------------------
'  R01   2010/09/30    INITIAL
'
'
'==============================================================================
'ErrHandler V3.01
Public Function GetDirContents( _
   sDirectory As String, _
   Optional Delimiter As String = ";" _
   ) As DIRECTORYCONTENTS
On Error GoTo Error_Proc
Dim Ret As DIRECTORYCONTENTS
'=========================
 Dim v As Variant  'variant array to hold returns
 Dim s As String   'string to hold returns
 Dim sT As String  'temp file placeholder
 Dim l As Long     'counter/loop iterator
 Dim lAttr As Long 'attributes placeholder
'=========================

 If Right(sDirectory, 1) <> "\" Then sDirectory = sDirectory & "\"

 'get the complete list
 sT = Dir(sDirectory, 55)
 While sT <> ""
   s = s & ";" & sT
   sT = Dir()
 Wend
 
 If s = "" Then GoTo Exit_Proc
 
 'remove leading delimiter
 s = Right(s, Len(s) - 1)
 
 'remove the "." and ".."
 s = Replace(s, ".;", "", 1, 1)
 s = Replace(s, "..;", "", 1, 1)
 
 'split into the array
 v = Split(s, ";")
 
 'sort the array
 QSortInPlace v
 
 
 'start building the return structure
 
 'get the total count
 Ret.dcCount = UBound(v) + 1
 
 For l = 0 To UBound(v)
   'get the attributes of the item
   lAttr = GetAttr(sDirectory & v(l))
   With Ret
   
     If lAttr And vbDirectory Then
       'this item is a directory
       .dcDirectories = .dcDirectories & Delimiter & v(l)
       .dcDirectory = .dcDirectory + 1
     Else
       'this item is a file
       .dcFiles = .dcFiles & Delimiter & v(l)
     End If
     
     'add counts to applicable file properties
     If lAttr And vbArchive Then .dcArchive = .dcArchive + 1
     If lAttr And vbSystem Then .dcSystem = .dcSystem + 1
     If lAttr And vbHidden Then .dcHidden = .dcHidden + 1
     If lAttr And vbReadOnly Then .dcReadOnly = .dcReadOnly + 1
     
   End With
 
 Next
 
 'cleanup the return structure
 '(remove leading delimiter from list strings)
 With Ret
   If .dcDirectories <> "" Then
     .dcDirectories = Right( _
                     .dcDirectories, Len(.dcDirectories) - Len(Delimiter))
   End If
   If .dcFiles <> "" Then
     .dcFiles = Right(.dcFiles, Len(.dcFiles) - Len(Delimiter))
   End If
 End With
 
'=========================
Exit_Proc:
 GetDirContents = Ret
 Exit Function
Error_Proc:
 Select Case Err.Number
   Case Else
     MsgBox "Error: " & Trim(str(Err.Number)) & vbCrLf & _
       "Desc: " & Err.Description & vbCrLf & vbCrLf & _
       "Module: modGetDirContents, Procedure: GetDirContents" _
       , vbCritical, "Error!"
 End Select
 Resume Exit_Proc
 Resume
End Function