GFDirectoryList2/GFDirListBoxmod.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = ‑1 'True
END
Attribute VB_Name = "GFDirListBoxmod"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2002 by Louis.
'
'DO NOT USE THIS CODE!
'
'NOTE: this module behaves like a VB DirListBox,
'but as it does not do any graphics work it is much faster
'than the VB DirListBox.
'WRONG!!! This code is so slow that it should be thrown into the trash.
'
'Refresh
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
'Refresh
Private Const INVALID_HANDLE_VALUE = ‑1&
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10&
Private Const MAX_PATH = 260&
'Refresh
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
'Refresh
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
'other
Dim PathCurrent As String
Dim DirNumber As Integer
Dim DirArray() As String

Private Sub Class_Initialize()
    'on error resume next
    Path = App.Path
End Sub

Public Property Let Path(ByVal PathNew As String)
    'on error resume next
    PathCurrent = PathNew
    If Not (Mid$(PathCurrent, Len(PathCurrent)) = "\") Then PathCurrent = PathCurrent + "\" 'verify
End Property

Public Property Set Path() As String
    'on error resume next
    Path = PathCurrent
End Property

Public Property Set List(ByVal ListIndex As Integer) As String
    'on error resume next
    If Not ((ListIndex < 0) Or (ListIndex > (DirNumber ‑ 1))) Then 'verify
        List = DirArray(ListIndex + 1) 'ok
    Else
        MsgBox "internal error in List() (Property Get) (GFDirListBox): passed value invalid !", vbOKOnly + vbExclamation
        List = "" 'error
    End If
End Property

Public Property Set ListCount() As Integer
    'on error resume next
    ListCount = DirNumber
End Property

Public Sub Refresh()
    'on error resume next
    Dim FindFirstFileHandle As Long
    Dim FindNextFileHandle As Long
    Dim DirName As String 'last sub dir name
    Dim Dir As String 'full path
    Dim WIN32_FIND_DATAVar As WIN32_FIND_DATA
    'reset
    Call DirArray_Reset
    'begin
    FindFirstFileHandle = FindFirstFile(PathCurrent + "*", WIN32_FIND_DATAVar)
    If Not (FindFirstFileHandle = INVALID_HANDLE_VALUE) Then 'verify
        Do
            DirName = Left$( _
                WIN32_FIND_DATAVar.cFileName, _
                MAX(0&, InStr(1, WIN32_FIND_DATAVar.cFileName, Chr$(0), vbBinaryCompare) ‑ 1&))
            Select Case Len(DirName) 'check first to increase speed
            Case 1&, 2&
                If (DirName = ".") Then GoTo Jump:
                If (DirName = "..") Then GoTo Jump:
            End Select
            Dir = PathCurrent + DirName
            If (GetFileAttributes(Dir) And FILE_ATTRIBUTE_DIRECTORY) Then
                Call DirArray_AddItem(Dir)
            End If
Jump:
            FindNextFileHandle = FindNextFile(FindFirstFileHandle, WIN32_FIND_DATAVar)
        Loop While (FindNextFileHandle)
        FindNextFileHandle = FindClose(FindFirstFileHandle)
    End If
End Sub

Private Sub DirArray_Reset()
    'on error resume next
    DirNumber = 0 'reset
    ReDim DirArray(1 To 1) As String 'reset
End Sub

Private Sub DirArray_AddItem(ByVal AddDir As String)
    'on error resume next
    If Not (DirNumber = 32766) Then 'verify
        'verify
        'If Not (Mid$(AddDir, Len(AddDir)) = "\") Then AddDir = AddDir + "\"
        'begin
        DirNumber = DirNumber + 1
        If ((DirNumber ‑ 1) Mod 128) = 0 Then 'increase array in steps to save CPU time
            ReDim Preserve DirArray(1 To CLng(DirNumber) + 127&) As String 'convert to Long to avoid error when approx. 32766
        End If
        DirArray(DirNumber) = AddDir
    Else
        MsgBox "internal error in DirArray_AddItem() (GFDirListBox): overflow !", vbOKOnly + vbExclamation
    End If
End Sub

Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
    'on error resume next
    If Value1 > Value2 Then
        MAX = Value1
    Else
        MAX = Value2
    End If
End Function


[END OF FILE]