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 LongByVal wMsg As LongByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As StringByVal lpszShortPath As StringByVal cchBuffer As Long) As Long
'GetDirectoryNameExEx
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As AnyByVal 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 IntegerByRef 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 LongByRef 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 LongByRef 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 StringByRef 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 StringByRef 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]