I needed this functionality today and found this in my MZTools code library. It's originally from UtterAccess, but apparently their Wiki is not on line currently.
Note that it requires a UDT, and no API.
Code:
' 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 Folder
'
' RETURNS: FOLDERCONTENTS structure
' This procedure does not raise an error on an invalid
' Folder parameter
'
' ARGUMENTS: sFolder - Folder 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 FOLDERCONTENTS
' dcCount As Long 'number of files and Folders
' dcFolder As Long 'number of Folders
' dcFiles As String 'delimited list of files
' dcFolders As String 'delimited list of Folders
' 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 Folder 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 Folders sorted
' by numerically and alphabetically
'
'
'
' EXAMPLE USAGE:
' ----------
' Sub PrintDirInfo(sDir As String)
' Dim dc As FOLDERCONTENTS
' dc = GetDirContents(sDir)
' With dc
' Debug.Print "Folder List: " .dcFolders & vbCrLf
' Debug.Print "File List: " & .dcFiles & vbCrLf
' Debug.Print "Item Count: " & .dcCount & vbCrLf
' Debug.Print "Number of Folders: " & .dcFolder & 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
' R02 2022/06/18 Enhance davegri- mod to default extract attribute to vbDirectory,
' to omit system and hidden files.
' Changed some variable names for clarity
'==============================================================================
'ErrHandler V3.01
Public Function GetDirContents(sFolder As String, Optional Delimiter As String = ";") As FOLDERCONTENTS
On Error GoTo Error_Proc
Dim Ret As FOLDERCONTENTS
'=========================
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 i As Long 'counter/loop iterator
Dim lAttr As Long 'attributes placeholder
'=========================
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
'get the complete list
sT = Dir(sFolder, vbDirectory)
'sT = Dir(sFolder, vbNormal)
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 i = 0 To UBound(v)
'get the attributes of the item
lAttr = GetAttr(sFolder & v(i))
With Ret
If lAttr And vbDirectory Then
'this item is a Folder
.dcFolders = .dcFolders & Delimiter & v(i)
.dcFolder = .dcFolder + 1
Else
'this item is a file
.dcFiles = .dcFiles & Delimiter & v(i)
'.dcFiles = .dcFiles & v(i) & vbCrLf
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 .dcFolders <> "" Then
.dcFolders = Right( _
.dcFolders, Len(.dcFolders) - 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, "E r r o r !"
End Select
Resume Exit_Proc
Resume
End Function
Is There a File Dialog Folder Picker That Shows Files?
Windows 10 
Access 2016
Reply With Quote
