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