GFDirectoryList4/GFDirListBox4cls.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = ‑1 'True
END
Attribute VB_Name = "GFDirListBox4cls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2004 by Louis.
'
'NOTE: this function can be used to create a GFDirListBox4,
'which is faster than a VB DirListBox and all previous GFDirListBoxes.
'NOTE: this time it runs REALLY fast! Send GFDirListBox[1‑3] to hell!
'NOTE: code partially copied from GFFileAccessmod, see there for further information.
'
'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
'Refresh
Private Const MAX_PATH As Long = 260
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
'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
'Refresh
Private Type ULARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
'other
Dim PathCurrent As String
Dim DirNumber As Long
Dim DirArray() As String
Private Sub Class_Initialize()
'on error resume next
Me.Path = App.Path
End Sub
'************************************INTERFACE SUBS*************************************
Public Property Let Path(ByVal PathNew As String)
'on error resume next
PathCurrent = PathNew
If Not (Mid$(PathCurrent, Len(PathCurrent)) = "\") Then PathCurrent = PathCurrent + "\" 'verify (important)
End Property
Public Property Set Path() As String
'on error resume next
Path = PathCurrent
End Property
Public Property Set List(ByVal ListIndex As Long) 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 Long
'on error resume next
ListCount = DirNumber
End Property
Public Sub Refresh()
'on error resume next
Dim FindFileHandle As Long
Dim FileName As String
Dim DirFor As Long
Dim WIN32_FIND_DATAVar As WIN32_FIND_DATA
Dim Temp As Long
'reset
Call DirArray_Reset
'begin
FindFileHandle = FindFirstFile(Path + "*", WIN32_FIND_DATAVar)
If FindFileHandle > 0& Then 'verify (if user enters a wrong directory)
ReDo:
Temp = InStr(1&, WIN32_FIND_DATAVar.cFileName, Chr$(0), vbBinaryCompare) 'cFileName is a fixed length string
'NOTE: function finds also hidden or system directories.
If (WIN32_FIND_DATAVar.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
'
If (Temp > 0&) Then
FileName = Left$(WIN32_FIND_DATAVar.cFileName, Temp ‑ 1&)
Else
FileName = WIN32_FIND_DATAVar.cFileName
End If
'
Select Case FileName
Case ".", ".."
Case Else
Call DirArray_AddItem(PathCurrent + FileName)
End Select
'
End If
If FindNextFile(FindFileHandle, WIN32_FIND_DATAVar) > 0& Then GoTo ReDo:
Call FindClose(FindFileHandle)
End If
End Sub
'***GFDIRLISTBOX3 FUNCTIONS***
Public Sub Dirs_SortByLength_Lng(ByVal SubDirNumber As Long, ByRef SubDirArray() As String) 'partially copied from Uninstaller
'on error resume next 'uses a rather stupid but simple algorithm to sort the strings in the array by their length (longest one comes to SubDirArray(1))
Dim SubDirLengthArray() As Long
Dim SubDirLengthMax As Long
Dim SubDirLengthMaxIndex As Long
Dim StructFor As Long
Dim SubDirFor As Long
Dim Temp As Long
Dim Tempstr$
'
'NOTE: the code below sorts all sub directories by their length
'(the longest one comes first). The algorithm has been tested successfully.
'WARNING: lame algorithm, could be improved.
'
'preset
If SubDirNumber > 0 Then
ReDim SubDirLengthArray(1 To SubDirNumber) As Long
For StructFor = 1 To SubDirNumber
SubDirLengthArray(StructFor) = Len(SubDirArray(StructFor))
Next StructFor
Else
Exit Sub 'nothing to do
End If
'begin
SubDirFor = 1 'preset
Do
SubDirLengthMax = 0 'reset
For StructFor = SubDirFor To SubDirNumber
If SubDirLengthArray(StructFor) > SubDirLengthMax Then
SubDirLengthMax = SubDirLengthArray(StructFor)
SubDirLengthMaxIndex = StructFor
End If
Next StructFor
'
If SubDirLengthMax = 0 Then Exit Do 'the one and only escape from loop
'
Tempstr$ = SubDirArray(SubDirFor)
SubDirArray(SubDirFor) = SubDirArray(SubDirLengthMaxIndex)
SubDirArray(SubDirLengthMaxIndex) = Tempstr$
Temp = SubDirLengthArray(SubDirFor)
SubDirLengthArray(SubDirFor) = SubDirLengthArray(SubDirLengthMaxIndex)
SubDirLengthArray(SubDirLengthMaxIndex) = Temp
SubDirLengthArray(SubDirFor) = 0 'do not use anymore
SubDirFor = SubDirFor + 1
Loop 'Until (SubDirFor = 32767) 'avoid endless loop
Exit Sub
End Sub
Public Sub Dirs_SortByLength_RevLng(ByVal SubDirNumber As Long, ByRef SubDirArray() As String)
'on error resume next 'uses a rather stupid but simple algorithm to sort the strings in the array by their length (shortest one comes to SubDirArray(1))
Dim SubDirLengthArray() As Long
Dim SubDirLengthMin As Long
Dim SubDirLengthMinIndex As Long
Dim StructFor As Long
Dim SubDirFor As Long
Dim Temp As Long
Dim Tempstr$
'
'NOTE: the code below sorts all sub directories by their length
'(the longest one comes first). The algorithm has been tested successfully.
'WARNING: lame algorithm, could be improved.
'
'preset
If SubDirNumber > 0 Then
ReDim SubDirLengthArray(1 To SubDirNumber) As Long
For StructFor = 1 To SubDirNumber
SubDirLengthArray(StructFor) = Len(SubDirArray(StructFor))
Next StructFor
Else
Exit Sub 'nothing to do
End If
'begin
SubDirFor = 1 'preset
Do
SubDirLengthMin = 256& ^ 3& 'reset
For StructFor = SubDirFor To SubDirNumber
If SubDirLengthArray(StructFor) < SubDirLengthMin Then
SubDirLengthMin = SubDirLengthArray(StructFor)
SubDirLengthMinIndex = StructFor
End If
Next StructFor
'
If SubDirLengthMin = 256& ^ 3& Then Exit Do 'the one and only escape from loop
'
Tempstr$ = SubDirArray(SubDirFor)
SubDirArray(SubDirFor) = SubDirArray(SubDirLengthMinIndex)
SubDirArray(SubDirLengthMinIndex) = Tempstr$
Temp = SubDirLengthArray(SubDirFor)
SubDirLengthArray(SubDirFor) = SubDirLengthArray(SubDirLengthMinIndex)
SubDirLengthArray(SubDirLengthMinIndex) = Temp
SubDirLengthArray(SubDirFor) = 0 'do not use anymore
SubDirFor = SubDirFor + 1
Loop 'Until (SubDirFor = 32767) 'avoid endless loop
Exit Sub
End Sub
'***END OF GFDIRLISTBOX3 FUNCTIONS***
'*********************************END OF INTERFACE SUBS*********************************
'************************************DIRECTORY ARRAY************************************
'NOTE: DirArray() saves the directory names that were 'created' when calling Refresh.
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
'verify
If Not (Mid$(AddDir, Len(AddDir)) = "\") Then AddDir = AddDir + "\" 'verify (important)
'begin
DirNumber = DirNumber + 1&
If ((DirNumber ‑ 1&) Mod 1024&) = 0& Then 'increase array size in steps to save CPU time
ReDim Preserve DirArray(1 To DirNumber + 1023&) As String
End If
DirArray(DirNumber) = AddDir
End Sub
'********************************END OF DIRECTORY ARRAY*********************************
'***END OF MODULE***
[END OF FILE]