GFDirectoryList3/Testfrm.frm

VERSION 5.00
Begin VB.Form Testfrm
   Caption         =   "GFDirectoryList3"
   ClientHeight    =   3075
   ClientLeft      =   60
   ClientTop       =   465
   ClientWidth     =   4635
   LinkTopic       =   "Form1"
   ScaleHeight     =   3075
   ScaleWidth      =   4635
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command3
      Caption         =   "GFDirListBox3 Debug"
      Height          =   315
      Left            =   2400
      TabIndex        =   4
      Top             =   1560
      Width           =   2115
   End
   Begin VB.CommandButton Command2
      Cancel          =   ‑1 'True
      Caption         =   "GFDirListBox3 Directory Functions Debug"
      Height          =   555
      Left            =   2400
      TabIndex        =   3
      Top             =   1980
      Width           =   2115
   End
   Begin VB.ListBox GFDirectoryList3List
      Enabled         =   0   'False
      Height          =   255
      Left            =   120
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   120
      Visible         =   0   'False
      Width           =   195
   End
   Begin VB.TextBox Text1
      Height          =   285
      Left            =   120
      TabIndex        =   1
      Top             =   2640
      Width           =   2175
   End
   Begin VB.CommandButton Command1
      Caption         =   "Get Dirs"
      Height          =   315
      Left            =   2400
      TabIndex        =   2
      Top             =   2640
      Width           =   2115
   End
End
Attribute VB_Name = "Testfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2002 by Louis.
'GFDirectoryList3
Dim GFDirectoryList3GFDirListBox3 As New GFDirListBox3cls
Dim GFDirectoryList3Number As Integer
Dim GFDirectoryList3Array() As String
Dim GFDirectoryList3CancelFlag As Boolean

Private Sub Command1_Click()
    'on error resume next
    Dim DirNumber As Integer
    Dim DirArray() As String
    Dim DirLoop As Integer
    Dim t As Single
    'begin
    '
    t = Timer
    Call GFDirectoryList3_Create(Text1.Text, True, DirArray(), DirNumber)
    Debug.Print Timer ‑ t 'for drive C:\ on 31.12.03 15:07 191,7383
    Stop
    '
    For DirLoop = 1 To DirNumber
        Debug.Print DirArray(DirLoop)
    Next DirLoop
End Sub

Private Sub Command2_Click()
    'on error resume next
    Dim DirNameNative As String
    Dim DirNameExcluded As String
    Dim DirExtended As String
    'begin
    DirNameNative = "[progra~1]"
    Call GFDirectoryList3GFDirListBox3.DirName_Exclude(DirNameNative, DirNameExcluded)
    Call GFDirectoryList3GFDirListBox3.Dir_Extend("C:\" + DirNameExcluded, DirExtended)
    Debug.Print DirExtended
End Sub

Private Sub Command3_Click()
    'on error resume next
    Dim DirLoop As Integer
    'preset
    Call GFDirectoryList3GFDirListBox3.Initialize(Me.GFDirectoryList3List)
    GFDirectoryList3GFDirListBox3.Path = "C:\System\"
    GFDirectoryList3GFDirListBox3.Refresh
    'begin
    For DirLoop = 1 To GFDirectoryList3GFDirListBox3.ListCount
        Debug.Print GFDirectoryList3GFDirListBox3.List(DirLoop ‑ 1)
    Next DirLoop
End Sub

'***GFDirectoryList3***
'NOTE: GFDirectoryList3 works like GFDirectoryList, but instead of a
'VB DirListBox we use the faster GFDirListBox.

Private Function GFDirectoryList3_Create(ByVal ScanStartDir As StringByVal AddScanStartDirFlag As BooleanByRef GFDirectoryList3ArrayPassed() As StringByRef GFDirectoryList3NumberPassed As Integer) As Boolean
    On Error GoTo Error: 'v2.0 (aborting possible); returns True if successful, False if error (if e.g. ScanStartDir is invalid)
    Dim Temp As Long
    '
    'NOTE: this function initializes passed array with the full name of all
    'sub directories of ScanStartDir (format: x:\x\).
    '
    'preset
    Call GFDirectoryList3GFDirListBox3.Initialize(Me.GFDirectoryList3List)
    'reset
    GFDirectoryList3Number = 0 'reset
    ReDim GFDirectoryList3Array(1 To 1) As String 'reset
    GFDirectoryList3CancelFlag = False 'reset
    'scan beginning in ScanStartDir
    If AddScanStartDirFlag = True Then
        Call GFDirectoryList3_AddItem(ScanStartDir)
    End If
    GFDirectoryList3GFDirListBox3.Path = ScanStartDir
    GFDirectoryList3GFDirListBox3.Refresh
    Call GFDirectoryList3_Scan("")
    If GFDirectoryList3CancelFlag = True Then GoTo Error:
    'transfer scan result
    GFDirectoryList3NumberPassed = GFDirectoryList3Number
    If Not (GFDirectoryList3NumberPassed = 0) Then 'verify
        ReDim GFDirectoryList3ArrayPassed(1 To GFDirectoryList3NumberPassed) As String
    Else
        ReDim GFDirectoryList3ArrayPassed(1 To 1) As String
    End If
    For Temp = 1 To GFDirectoryList3NumberPassed
        GFDirectoryList3ArrayPassed(Temp) = GFDirectoryList3Array(Temp)
    Next Temp
    GFDirectoryList3_Create = True 'ok
    Exit Function
Error:
    GFDirectoryList3_Create = False 'error
    Exit Function
End Function

Private Sub GFDirectoryList3_Scan(ByRef ScanDirOld As String)
    On Error GoTo Error: 'important (avoid endless loop)
    Dim ScanDirNumberTotal As Integer
    Dim ScanParentDir As String
    ScanDirNumberTotal = GFDirectoryList3GFDirListBox3.ListCount
    Do While ScanDirNumberTotal > 0
        ScanParentDir = GFDirectoryList3GFDirListBox3.Path
        If GFDirectoryList3GFDirListBox3.ListCount > 0 Then
            GFDirectoryList3GFDirListBox3.Path = GFDirectoryList3GFDirListBox3.List(ScanDirNumberTotal ‑ 1) 'jump to Error: if i.e. network drive was disconnected
            GFDirectoryList3GFDirListBox3.Refresh
            Call GFDirectoryList3_AddItem(GFDirectoryList3GFDirListBox3.Path)
            Call GFDirectoryList3_Scan(ScanParentDir)
            If GFDirectoryList3CancelFlag = True Then Exit Sub 'recursive call used, leave all subs
        End If
        ScanDirNumberTotal = ScanDirNumberTotal ‑ 1
    Loop
    If Not (ScanDirOld = "") Then
        GFDirectoryList3GFDirListBox3.Path = ScanDirOld
        GFDirectoryList3GFDirListBox3.Refresh 'DoEvents was removed
        Call GFDirectoryList3_DoEvents(GFDirectoryList3CancelFlag)
    End If
    Exit Sub
Error:
    'do nothing
    Exit Sub
End Sub

Private Sub GFDirectoryList3_AddItem(ByVal Directory As String)
    'on error resume next
    If Not (GFDirectoryList3Number = 32767) Then 'verify
        GFDirectoryList3Number = GFDirectoryList3Number + 1
    Else
        Exit Sub 'error
    End If
    If Not (Right$(Directory, 1) = "\") Then Directory = Directory + "\" 'verify
    If ((GFDirectoryList3Number ‑ 1) Mod 128) = 0 Then 'resize array in steps to save CPU time
        ReDim Preserve GFDirectoryList3Array(1 To GFDirectoryList3Number + 127) As String
    End If
    GFDirectoryList3Array(GFDirectoryList3Number) = Directory
    Exit Sub
End Sub

Private Sub GFDirectoryList3_DoEvents(ByRef CancelFlag As Boolean)
    'on error resume next
    '***DEBUG SPECIFIC***
    DoEvents
    'If Check1.Value = 1 Then CancelFlag = True
    '***END OF DEBUG SPECIFIC***
End Sub

'***END OF GFDirectoryList3***


[END OF FILE]