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 String, ByVal AddScanStartDirFlag As Boolean, ByRef GFDirectoryList3ArrayPassed() As String, ByRef 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]