VB6 - Directory List

[couttsj]

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.

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 Sub

This code requires 3 Command Buttons and 3 List Boxes.

J.A. Coutts

[fafalone]

We went really deep with fast enumeration before... if you want to smoke FindFirstFile look for the threads using NtQueryDirectoryFile or DeviceIoControl to read the info straight off the disk driver, DeviceIoControl-FSCTL_ENUM_USN_DATA will annihilate any other method short of kernel mode methods

[couttsj]

The code in post 1 has been updated. I needed to supply a directory list that included the file length and had to be transmitted over a network. Because network speed is so much slower than system speed, I wanted to use byte data rather than string data. So I added a third option to perform that function called FileList.

A timer routine was also added, but is not very accurate because of the minimum Dynamic Tick duration (15.6 ms). To get it to show anything meaningful I had to add a Sleep 5.

J.A. Coutts

[couttsj]

In Command3 I used the VB6 function FileLen, and I wanted to find out if the API was faster. It is my understanding that FileLen has to create a handle for each file, open each file, and GetFileSize, much the same as what the API does. So I added a fourth Command utilizing a function I called FileSize (not added to original post).

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileSizeEx Lib "kernel32" (ByVal hFile As Long, lpFileSize As Long) As Boolean
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Function FileSize(ByVal strFilePath As String) As Long
    Dim hFile As Long
    Dim nSize As Long
    hFile = CreateFile(strFilePath, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, ByVal 0&, ByVal 0&)
    GetFileSizeEx hFile, nSize
    CloseHandle hFile
    FileSize = nSize
End Function

To get a better speed measurement, I used a larger test directory and changed the buffer size to 2^16. The results however were inconclusive. Sometimes FileSize was faster and other times FileLen was faster.

J.A. Coutts

[VanGoghGaming]

BOOL GetFileSizeEx(
  [in]  HANDLE         hFile,
  [out] PLARGE_INTEGER lpFileSize
);

translates to:

Private Enum BOOL
    APIFALSE
    APITRUE
End Enum

Private Type LARGE_INTEGER
    LowPart As Long
    HighPart As Long
End Type

Private Declare Function GetFileSizeEx Lib "kernel32" (ByVal hFile As Long, lpFileSize As LARGE_INTEGER) As BOOL

However you can get the file size without opening the file first:

Public Function FileSize(sPath As String) As Currency
Dim FileAttributeData As WIN32_FILE_ATTRIBUTE_DATA, cFileSizeLow As Currency, cFileSizeHigh As Currency
Const cMaxInt As Currency = 2 ^ 32
    If GetFileAttributesExW(StrPtr(sPath), 0, VarPtr(FileAttributeData)) Then
        With FileAttributeData
            If .nFileSizeLow < 0 Then cFileSizeLow = .nFileSizeLow + cMaxInt Else cFileSizeLow = .nFileSizeLow
            If .nFileSizeHigh < 0 Then cFileSizeHigh = .nFileSizeHigh + cMaxInt Else cFileSizeHigh = .nFileSizeHigh
        End With
        FileSize = cFileSizeLow + cFileSizeHigh * cMaxInt
    End If
End Function

[couttsj]

Thanks for the tip VanGoghGaming. I had a little trouble getting your code to work, but a quick search found an old post from Bonnie West: https://www.vbforums.com/showthread....rn-file-length .

Option Explicit

Private Type WIN32_FILE_ATTRIBUTE_DATA
    dwFileAttributes As Long
    ftCreationTime   As Currency
    ftLastAccessTime As Currency
    ftLastWriteTime  As Currency
    nFileSizeHigh    As Long
    nFileSizeLow     As Long
End Type

Private Declare Function GetFileAttributesExW Lib "kernel32.dll" (ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByVal NewVal As Long)

Public Function FileLenW(ByRef PathName As String) As Currency
    Const GetFileExInfoStandard = 0&
    Const SIGN_BIT = &H80000000
    Dim WFAD As WIN32_FILE_ATTRIBUTE_DATA
    If GetFileAttributesExW(StrPtr(PathName), GetFileExInfoStandard, WFAD) Then
        PutMem4 VarPtr(FileLenW), WFAD.nFileSizeLow
        PutMem4 (VarPtr(FileLenW) Xor SIGN_BIT) + 4 Xor SIGN_BIT, WFAD.nFileSizeHigh
        FileLenW = FileLenW * 10000
    End If
End Function

Private Sub Command1_Click()
    Debug.Print FileLenW("C:\Share\EndCliff.jpg")
End Sub

I was not aware of this possibility.

J.A. Coutts

[VanGoghGaming]

Those PutMem4 calls are putting a damper on execution speed.

You should have been able to spot this yourself but this is the definition of the GetFileAttributesExW function that works with the sample above:

Private Declare Function GetFileAttributesExW(ByVal lpFileName As LongPtr, ByVal fInfoLevelId As Long, ByVal lpFileInformation As LongPtr) As BOOL

[couttsj]

After extensive testing I found no significant difference in speed between FileLen and both forms of API FileSize, in both the IDE and compiled. I will stick with FileLen as it is much easier to implement, and I don't particularly need the large file capability.

J.A. Coutts