GFDirectoryList4/Testfrm.frm

VERSION 5.00
Begin VB.Form Testfrm
   Caption         =   "GFDirectoryList4"
   ClientHeight    =   3075
   ClientLeft      =   60
   ClientTop       =   465
   ClientWidth     =   4635
   LinkTopic       =   "Form1"
   ScaleHeight     =   3075
   ScaleWidth      =   4635
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.TextBox Text1
      Height          =   315
      Left            =   120
      TabIndex        =   0
      ToolTipText     =   "enter scan root dir"
      Top             =   2640
      Width           =   2175
   End
   Begin VB.CommandButton Command1
      Caption         =   "Get Dirs"
      Height          =   315
      Left            =   2400
      TabIndex        =   1
      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‑2004 by Louis.
'
'Downloaded from www.louis‑coder.com.
'Searches sub directories of any root drive and stores their names in an array.
'To use the GFDirectoryList4, copy this form's code (except Command1_Click)
'to your project and add GFDirListBox4cls. With a call of GFDirectoryList4_Create()
'you can create a sub directory list. GFDirectoryList4_DoEvents() is called
'automatically from time to time, place code to abort the search there.
'
'GFDirectoryList4
Dim GFDirectoryList4GFDirListBox4 As New GFDirListBox4cls
Dim GFDirectoryList4Number As Long
Dim GFDirectoryList4Array() As String
Dim GFDirectoryList4CancelFlag As Boolean

Private Sub Command1_Click()
    'on error resume next
    Dim DirNumber As Long
    Dim DirArray() As String
    Dim DirFor As Long
    Dim t As Single
    'begin
    '
    t = Timer
    Call GFDirectoryList4_Create(Text1.Text, True, DirArray(), DirNumber)
    Call GFDirectoryList4GFDirListBox4.Dirs_SortByLength_Lng(DirNumber, DirArray())
    Call GFDirectoryList4GFDirListBox4.Dirs_SortByLength_RevLng(DirNumber, DirArray())
    Debug.Print Timer ‑ t 'for drive C:\ on 31.12.03 15:07 121,0
    Stop
    '
    For DirFor = 1 To DirNumber '10684
        Debug.Print DirArray(DirFor)
    Next DirFor
End Sub

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

Private Function GFDirectoryList4_Create(ByVal ScanStartDir As String, ByVal AddScanStartDirFlag As Boolean, ByRef GFDirectoryList4ArrayPassed() As String, ByRef GFDirectoryList4NumberPassed As Long) 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\).
    '
    'reset
    GFDirectoryList4Number = 0 'reset
    ReDim GFDirectoryList4Array(1 To 1) As String 'reset
    GFDirectoryList4CancelFlag = False 'reset
    'scan beginning in ScanStartDir
    If AddScanStartDirFlag = True Then
        Call GFDirectoryList4_AddItem(ScanStartDir)
    End If
    GFDirectoryList4GFDirListBox4.Path = ScanStartDir
    GFDirectoryList4GFDirListBox4.Refresh
    Call GFDirectoryList4_Scan("")
    If GFDirectoryList4CancelFlag = True Then GoTo Error:
    'transfer scan result
    GFDirectoryList4NumberPassed = GFDirectoryList4Number
    If Not (GFDirectoryList4NumberPassed = 0) Then 'verify
        ReDim GFDirectoryList4ArrayPassed(1 To GFDirectoryList4NumberPassed) As String
    Else
        ReDim GFDirectoryList4ArrayPassed(1 To 1) As String
    End If
    For Temp = 1 To GFDirectoryList4NumberPassed
        GFDirectoryList4ArrayPassed(Temp) = GFDirectoryList4Array(Temp)
    Next Temp
    GFDirectoryList4_Create = True 'ok
    Exit Function
Error:
    GFDirectoryList4_Create = False 'error
    Exit Function
End Function

Private Sub GFDirectoryList4_Scan(ByRef ScanDirOld As String)
    On Error GoTo Error: 'important (avoid endless loop)
    Dim ScanDirNumberTotal As Long
    Dim ScanParentDir As String
    'begin
    ScanDirNumberTotal = GFDirectoryList4GFDirListBox4.ListCount
    Do While ScanDirNumberTotal > 0&
        ScanParentDir = GFDirectoryList4GFDirListBox4.Path
        If GFDirectoryList4GFDirListBox4.ListCount > 0& Then
            GFDirectoryList4GFDirListBox4.Path = GFDirectoryList4GFDirListBox4.List(ScanDirNumberTotal ‑ 1&)
            GFDirectoryList4GFDirListBox4.Refresh
            Call GFDirectoryList4_AddItem(GFDirectoryList4GFDirListBox4.Path)
            Call GFDirectoryList4_Scan(ScanParentDir)
            If GFDirectoryList4CancelFlag = True Then Exit Sub 'recursive call used, leave all subs
        End If
        ScanDirNumberTotal = ScanDirNumberTotal ‑ 1&
    Loop
    If (Len(ScanDirOld)) Then
        GFDirectoryList4GFDirListBox4.Path = ScanDirOld
        GFDirectoryList4GFDirListBox4.Refresh 'DoEvents was removed
        Call GFDirectoryList4_DoEvents(GFDirectoryList4CancelFlag)
    End If
    Exit Sub
Error:
    'do nothing
    Exit Sub
End Sub

Private Sub GFDirectoryList4_AddItem(ByVal Directory As String)
    'on error resume next
    'verify
    'If Not (Right$(Directory, 1) = "\") Then Directory = Directory + "\" 'verify; no, GFDirListBox4 already verified
    'begin
    GFDirectoryList4Number = GFDirectoryList4Number + 1&
    If ((GFDirectoryList4Number ‑ 1&) Mod 1024&) = 0& Then 'resize array in steps to save CPU time
        ReDim Preserve GFDirectoryList4Array(1& To GFDirectoryList4Number + 1023&) As String
    End If
    GFDirectoryList4Array(GFDirectoryList4Number) = Directory
    Exit Sub
End Sub

Private Sub GFDirectoryList4_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 GFDirectoryList4***


[END OF FILE]