In the past I have used VB commands to find the contents of a directory, but I wanted to speed things up. So I found a routine on Experts Exchange by Dana Seaman that showed some promise. It was very complete but much more than I really needed, so I developed my own simplified routine. The code below contains both, as well as a third routine as described in post #3.
This code requires 3 Command Buttons and 3 List Boxes.
J.A. Coutts
Code:
Option Explicit
Private Const MAX_PATH = 260
Dim tStart As Double
Public Enum FileAttributes
ReadOnly = &H1
Hidden = &H2
System = &H4
Volume = &H8
Directory = &H10
Archive = &H20
Alias = &H40 ' or Device [reserved]
Normal = &H80
Temporary = &H100
SparseFile = &H200
ReparsePoint = &H400
Compressed = &H800
Offline = &H1000
NotContentIndexed = &H2000
Encrypted = &H4000
Attr_ALL = ReadOnly Or Hidden Or System Or Archive Or Normal
End Enum
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As Currency
ftLastAccessTime As Currency
ftLastWriteTime As Currency
nFileSizeBig As Currency
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cShortFileName As String * 14
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function FindFirstFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal lpFindFileData As Long) As Long
Private Declare Function FindNextFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal lpFindFileData As Long) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub DebugPrintByte(sDescr As String, bArray() As Byte)
Dim lPtr As Long
On Error GoTo DebugErr
Debug.Print sDescr & ":"
For lPtr = 0 To UBound(bArray)
Debug.Print Right$("0" & Hex$(bArray(lPtr)), 2) & " ";
If (lPtr + 1) Mod 16 = 0 Then Debug.Print
Next lPtr
Debug.Print
DebugErr:
End Sub
Private Function EnumFolder(ByVal sPath As String, Optional ByVal sPattern As String = "*.*") As String
Dim hFile As Long
Dim lRet As Long
Dim sName As String
Dim wFD As WIN32_FIND_DATA
Dim sRet As String
hFile = FindFirstFileW(ByVal StrPtr(sPath & sPattern), VarPtr(wFD))
If hFile = -1 Then EnumFolder = "No files found!": Exit Function
Do
sName = Left(wFD.cFileName, InStr(wFD.cFileName, vbNullChar)) 'Retain NULL
If Not Asc(sName) = 46 Then 'skip . and .. entries
sRet = sRet & sName
End If
lRet = FindNextFileW(hFile, VarPtr(wFD))
Loop Until lRet = 0
lRet = FindClose(hFile)
EnumFolder = sRet
End Function
Public Sub EnumFolders(ByVal sPath As String, Optional ByVal sPattern As String = "*.*", Optional ByVal lAttributeFilter As FileAttributes = Attr_ALL, Optional ByVal bRecurse As Boolean = False)
Dim lHandle As Long
Dim sFileName As String
Dim Lines As Long
Dim wFD As WIN32_FIND_DATA
On Error GoTo ProcedureError
sPath = QualifyPath(sPath)
lHandle = FindFirstFileW(StrPtr(sPath & sPattern), VarPtr(wFD))
If lHandle > 0 Then
Do
With wFD
If AscW(.cFileName) <> 46 Then 'skip . and .. entries
sFileName = StripNull(.cFileName)
If (.dwFileAttributes And Directory) Then
If bRecurse Then
EnumFolders sPath & sFileName, sPattern, lAttributeFilter, bRecurse
End If
ElseIf (.dwFileAttributes And lAttributeFilter) Then
List1.AddItem sFileName
End If
End If
End With
Loop While FindNextFileW(lHandle, VarPtr(wFD)) > 0
End If
FindClose lHandle
Exit Sub
ProcedureError:
Debug.Print "Error " & Err.Number & " " & Err.Description & " of EnumFolders"
End Sub
Private Function GetbSize(bArray() As Byte) As Long
On Error GoTo GetSizeErr
GetbSize = UBound(bArray) + 1
Exit Function
GetSizeErr:
GetbSize = 0
End Function
Private Function FileList(ByVal sPath As String, Optional ByVal sPattern As String = "*.*") As Byte()
Dim hFile As Long
Dim lRet As Long
Dim sName As String
Dim wFD As WIN32_FIND_DATA
Dim bRet() As Byte
Dim lPtr As Long
Dim bResult(MAX_PATH) As Byte 'Fixed length req'd. Size to suit application.
hFile = FindFirstFileW(ByVal StrPtr(sPath & sPattern), VarPtr(wFD))
If hFile = -1 Then FileList = StrToUtf8("No files found!"): Exit Function
Do
sName = Left(wFD.cFileName, InStr(wFD.cFileName, vbNullChar) - 1) 'Remove NULL
If Not Asc(sName) = 46 Then 'skip . and .. entries
bRet = StrToUtf8(sName & Str(FileLen(sPath & sName))) 'Use of str adds a space
CopyMemory bResult(lPtr), bRet(0), GetbSize(bRet)
lPtr = lPtr + GetbSize(bRet) + 1 'Retain 1 NULL to act as separater
End If
lRet = FindNextFileW(hFile, VarPtr(wFD))
Loop Until lRet = 0
lRet = FindClose(hFile)
FileList = bResult
ReDim Preserve FileList(lPtr - 1)
End Function
Public Function StripNull(StrIn As String) As String
Dim nul As Long
nul = InStr(StrIn, vbNullChar)
If (nul) Then
StripNull = Left$(StrIn, nul - 1)
Else
StripNull = Trim$(StrIn)
End If
End Function
Public Function StrToUtf8(strInput As String) As Byte()
Const CP_UTF8 = 65001
Dim nBytes As Long
Dim bBuffer() As Byte
If Len(strInput) < 1 Then Exit Function
'Get length in bytes *including* terminating null
nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, 0&, 0&, 0&, 0&)
'NB ReDim without the terminating null
ReDim bBuffer(nBytes - 2)
nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(bBuffer(0)), nBytes - 1, 0&, 0&)
StrToUtf8 = bBuffer
End Function
Private Function Utf8ToStr(bUtf8Array() As Byte) As String
Const CP_UTF8 = 65001
Dim nBytes As Long
Dim nChars As Long
Dim strOut As String
nBytes = GetbSize(bUtf8Array)
If nBytes <= 0 Then Exit Function
'Get number of characters in output string
nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(bUtf8Array(0)), nBytes, 0&, 0&)
'Dimension output buffer to receive string
strOut = String(nChars, 0)
nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(bUtf8Array(0)), nBytes, StrPtr(strOut), nChars)
'Utf8ToStr = Replace(strOut, Chr$(0), "") 'Remove Null terminating character
Utf8ToStr = strOut
End Function
Public Function QualifyPath(ByVal Path As String) As String
Dim Delimiter As String ' segmented path delimiter
If InStr(Path, "://") > 0 Then ' it's a URL path
Delimiter = "/" ' use URL path delimiter
Else ' it's a disk based path
Delimiter = "\" ' use disk based path delimiter
End If
Select Case Right$(Path, 1) ' whats last character in path?
Case "/", "\" ' it's one of the valid delimiters
QualifyPath = Path ' use the supplied path
Case Else ' needs a trailing path delimiter
QualifyPath = Path & Delimiter ' append it
End Select
End Function
Private Sub Command1_Click()
'This routine is from Dana Seaman on Experts Excahange.
'https://www.experts-exchange.com/questions/26845334/VB6-fastest-way-to-get-filenames-in-a-folder.html
List1.Clear
tStart = Timer
EnumFolders "C:\Share"
Sleep 5
List1.AddItem CStr(CLng((Timer - tStart) * 1000))
End Sub
Private Sub Command2_Click()
'This is a simplified routine to list the contents of a single directory
'separated by a NULL character.
Dim sArray() As String
Dim N%
List2.Clear
tStart = Timer
sArray = Split(EnumFolder("C:\Share\"), vbNullChar)
For N% = 0 To UBound(sArray)
List2.AddItem sArray(N%)
Next N%
Sleep 5
List2.AddItem CStr(CLng((Timer - tStart) * 1000))
End Sub
Private Sub Command3_Click()
'This routine adds the file length to each entry & converts it to byte array.
Dim bTmp() As Byte
Dim sTmp As String
Dim sArray() As String
Dim N%
List3.Clear
tStart = Timer
bTmp = FileList("C:\Share\")
sTmp = Utf8ToStr(bTmp)
sArray = Split(sTmp, vbNullChar)
For N% = 0 To UBound(sArray)
List3.AddItem sArray(N%)
Next N%
Sleep 5
List3.AddItem CStr(CLng((Timer - tStart) * 1000))
End SubJ.A. Coutts