GFDirectoryList3/GFDirListBox3cls.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = ‑1 'True
END
Attribute VB_Name = "GFDirListBox3cls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2002 by Louis.
'
'NOTE: this function can be used to create a GFDirListBox3,
'which is faster than a VB DirListBox.
'
'Refresh
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'GetDirectoryNameExEx
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'Refresh
Private Const MAX_PATH As Long = 260
'Refresh
Private Const LB_DIR = &H18D
'Refresh
Private Const DDL_READWRITE As Long = &H0
Private Const DDL_READONLY As Long = &H1
Private Const DDL_HIDDEN As Long = &H2
Private Const DDL_SYSTEM As Long = &H4
Private Const DDL_DIRECTORY As Long = &H10
Private Const DDL_ARCHIVE As Long = &H20
Private Const DDL_POSTMSGS As Long = &H2000
Private Const DDL_DRIVES As Long = &H4000
Private Const DDL_EXCLUSIVE As Long = &H8000
'GetDirectoryNameExEx
Dim PathByteString(1 To MAX_PATH) As Byte
'other
Dim ListBoxObject As ListBox
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
'************************************INTERFACE SUBS*************************************
Public Sub Initialize(ByRef DirListObjectPassed As ListBox)
'on error resume next 'call once when starting up the target project
Set ListBoxObject = DirListObjectPassed
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 PathCurrentShort As String
Dim PathCurrentShortLength As String
Dim PathCurrentEx As String
Dim DirLoop As Integer
Dim DirName As String
Dim Dir As String
'verify
If ListBoxObject Is Nothing Then 'verify
MsgBox "internal error in Refresh (GFDirListBox3cls): initialize first !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'reset
Call DirArray_Reset
Call ListBoxObject.Clear 'reset (important)
'preset
PathCurrentShort = String$(MAX_PATH, Chr$(0))
PathCurrentShortLength = GetShortPathName(PathCurrent, PathCurrentShort, MAX_PATH)
PathCurrentEx = Left$(PathCurrentShort, PathCurrentShortLength) + "*.*" + Chr$(0)
'begin
Call SendMessage(ListBoxObject.hwnd, LB_DIR, DDL_DIRECTORY Or DDL_READONLY Or DDL_HIDDEN Or DDL_SYSTEM Or DDL_ARCHIVE, ByVal PathCurrentEx)
For DirLoop = 1 To ListBoxObject.ListCount
'
If DirName_Exclude(ListBoxObject.List(DirLoop ‑ 1), DirName) = False Then GoTo Jump:
'DirName is e.g. 'Progra~1'
'
Select Case Len(DirName)
Case 1&, 2&
If DirName = "." Then GoTo Jump:
If DirName = ".." Then GoTo Jump:
End Select
'
Call Dir_Extend(PathCurrent + DirName, Dir)
'Dir is e.g. 'C:\Programme\'
Call DirArray_AddItem(Dir)
Jump:
Next DirLoop
End Sub
Public Sub Dirs_SortByLength(ByVal SubDirNumber As Integer, 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 StructLoop As Integer
Dim SubDirLoop As Integer
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.
'
'preset
If SubDirNumber > 0 Then
ReDim SubDirLengthArray(1 To SubDirNumber) As Long
For StructLoop = 1 To SubDirNumber
SubDirLengthArray(StructLoop) = Len(SubDirArray(StructLoop))
Next StructLoop
Else
Exit Sub 'nothing to do
End If
'begin
SubDirLoop = 1 'preset
Do
SubDirLengthMax = 0 'reset
For StructLoop = SubDirLoop To SubDirNumber
If SubDirLengthArray(StructLoop) > SubDirLengthMax Then
SubDirLengthMax = SubDirLengthArray(StructLoop)
End If
Next StructLoop
If SubDirLengthMax = 0 Then Exit Do
ReDo:
For StructLoop = SubDirLoop To SubDirNumber
If SubDirLengthArray(StructLoop) = SubDirLengthMax Then
If Not (StructLoop = SubDirLoop) Then
Tempstr$ = SubDirArray(SubDirLoop)
SubDirArray(SubDirLoop) = SubDirArray(StructLoop)
SubDirArray(StructLoop) = Tempstr$
Temp = SubDirLengthArray(SubDirLoop)
SubDirLengthArray(SubDirLoop) = SubDirLengthArray(StructLoop)
SubDirLengthArray(StructLoop) = Temp
End If
SubDirLengthArray(SubDirLoop) = 0 'do not use anymore
SubDirLoop = SubDirLoop + 1
GoTo ReDo:
End If
Next StructLoop
Loop Until (SubDirLoop = 32767) 'avoid endless loop
Exit Sub
End Sub
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 StructFor As Long
Dim SubDirFor As Integer
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.
'
'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)
End If
Next StructFor
If SubDirLengthMax = 0 Then Exit Do 'the one and only escape from loop
ReDo:
For StructFor = SubDirFor To SubDirNumber
If SubDirLengthArray(StructFor) = SubDirLengthMax Then
If Not (StructFor = SubDirFor) Then
Tempstr$ = SubDirArray(SubDirFor)
SubDirArray(SubDirFor) = SubDirArray(StructFor)
SubDirArray(StructFor) = Tempstr$
Temp = SubDirLengthArray(SubDirFor)
SubDirLengthArray(SubDirFor) = SubDirLengthArray(StructFor)
SubDirLengthArray(StructFor) = Temp
End If
SubDirLengthArray(SubDirFor) = 0 'do not use anymore
SubDirFor = SubDirFor + 1
GoTo ReDo:
End If
Next StructFor
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 StructFor As Long
Dim SubDirFor As Integer
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.
'
'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)
End If
Next StructFor
If SubDirLengthMin = 256& ^ 3& Then Exit Do 'the one and only escape from loop
ReDo:
For StructFor = SubDirFor To SubDirNumber
If SubDirLengthArray(StructFor) = SubDirLengthMin Then
If Not (StructFor = SubDirFor) Then
Tempstr$ = SubDirArray(SubDirFor)
SubDirArray(SubDirFor) = SubDirArray(StructFor)
SubDirArray(StructFor) = Tempstr$
Temp = SubDirLengthArray(SubDirFor)
SubDirLengthArray(SubDirFor) = SubDirLengthArray(StructFor)
SubDirLengthArray(StructFor) = Temp
End If
SubDirLengthArray(SubDirFor) = 0 'do not use anymore
SubDirFor = SubDirFor + 1
GoTo ReDo:
End If
Next StructFor
Loop 'Until (SubDirFor = 32767) 'avoid endless loop
Exit Sub
End Sub
'*********************************END OF INTERFACE SUBS*********************************
'**********************************DIRECTORY FUNCTIONS**********************************
'NOTE: the following two procedures can be used to remove brackets from
'a directory name and to convert a short path name into a full path name.
Public Function DirName_Exclude(ByVal DirNameNative As String, ByRef DirNameExcluded As String) As Boolean
'on error resume next 'removes brackets ('[]') (if any)
Dim BracketLeftExistingFlag As Boolean
Dim BracketRightExistingFlag As Boolean
'
'NOTE: the following directory names could be passed (examples):
'‑'[progra~1]'
'‑'[progra~1'
'‑'progra~1]'
'‑'progra~1'
'DirNameExcluded would be set to 'progra~1'.
'This function returns only True if the passed native directory
'was located within two brackets (e.g. '[windows]).
'
'verify
If Len(DirNameNative) = 0 Then
DirNameExcluded = ""
DirName_Exclude = False
Exit Function
End If
'preset
BracketLeftExistingFlag = (Mid$(DirNameNative, 1, 1) = "[")
BracketRightExistingFlag = (Mid$(DirNameNative, Len(DirNameNative), 1) = "]")
'begin
If (BracketLeftExistingFlag = False) And (BracketRightExistingFlag = False) Then
DirNameExcluded = DirNameNative 'ok
DirName_Exclude = False
Exit Function
End If
If (BracketLeftExistingFlag = True) And (BracketRightExistingFlag = False) Then
DirNameExcluded = Mid$(DirNameNative, 2) 'ok
DirName_Exclude = False
Exit Function
End If
If (BracketLeftExistingFlag = False) And (BracketRightExistingFlag = True) Then
DirNameExcluded = Left$(DirNameNative, Len(DirNameNative) ‑ 1) 'ok
DirName_Exclude = False
Exit Function
End If
If (BracketLeftExistingFlag = True) And (BracketRightExistingFlag = True) Then
DirNameExcluded = Mid$(DirNameNative, 2, Len(DirNameNative) ‑ 2) 'ok
DirName_Exclude = True
Exit Function
End If
Exit Function
End Function
Public Function Dir_Extend(ByRef DirShort As String, ByRef DirLong As String)
'on error resume next 'converts short directories into long directories
'
'NOTE: e.g. 'C:\Progra~1\' or 'C:\Progra~1' would be converted into 'C:\Programme\'.
'
'begin
If Right$(DirShort, 1) = "\" Then
Dim DirShortWithoutBackSlash As String
DirShortWithoutBackSlash = Left$(DirShort, Len(DirShort) ‑ 1&)
DirLong = GetDirectoryNameEx(DirShortWithoutBackSlash) + Dir$(DirShortWithoutBackSlash, vbDirectory)
If Not (Right(DirLong, 1) = "\") Then DirLong = DirLong + "\"
Else
DirLong = GetDirectoryNameEx(DirShort) + Dir$(DirShort, vbDirectory Or vbHidden Or vbSystem Or vbArchive)
If Not (Right(DirLong, 1) = "\") Then DirLong = DirLong + "\"
End If
End Function
'******************************END OF DIRECTORY FUNCTIONS*******************************
'************************************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
'Debug.Print AddDir
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 size 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
'********************************END OF DIRECTORY ARRAY*********************************
'***********************************GENERAL FUNCTIONS***********************************
Private Function GetDirectoryNameEx(ByVal GetDirectoryNameExName As String) As String
'On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
Dim GetDirectoryNameExLoop As Integer
'
'NOTE: this function was manipulated and then named [...]Ex as a byte
'string is used for comparing operations to speed up the comparing.
'
'preset
GetDirectoryNameEx = "" 'reset
Call CopyMemory(PathByteString(1), ByVal GetDirectoryNameExName, Len(GetDirectoryNameExName))
'begin
For GetDirectoryNameExLoop = Len(GetDirectoryNameExName) To 1 Step (‑1)
If PathByteString(GetDirectoryNameExLoop) = 92 Then '\
GetDirectoryNameEx = Left$(GetDirectoryNameExName, GetDirectoryNameExLoop)
Exit For
End If
Next GetDirectoryNameExLoop
End Function
'*******************************END OF GENERAL FUNCTIONS********************************
'***END OF MODULE***
[END OF FILE]