Article ID: 189631
Article Last Modified on 3/3/2005
Option Explicit
Dim InF As String ' Starting Directory
Dim DS As String ' Buffer for RFT control text
Const nL = "{\par }"
Function DbS(ByVal txt As String) As String
Dim k As Long, kLast As Long
Dim nt As String
k = 1
kLast = 1
Do ' Replace all \ characters with \\
k = InStr(kLast, txt, "\")
If k = 0 Then
Exit Do
Else
txt = Left$(txt, k) & Right$(txt, Len(txt) - k + 1)
kLast = k + 2
End If
Loop
DbS = txt
End Function
' ============================ QuickSort ============================
' QuickSort works by picking a random "pivot" element in SortArray,
' then moving every element that is bigger to one side of the pivot,
' and every element that is smaller to the other side. QuickSort is
' then called recursively with the two subdivisions created by the
' pivot. Once the number of elements in a subdivision reaches two,
' the recursive calls end and the array is sorted.
' ===================================================================
'
Private Sub QuickSort(SortArray() As String, ByVal Low As Long, _
ByVal High As Long)
Dim I As Long, J As Long, RandIndex As Long, Partition As String
If Low < High Then
' Only two elements in this subdivision; swap them if they are
' out of order, then end recursive calls:
If High - Low = 1 Then
If UCase(SortArray(Low)) > UCase(SortArray(High)) Then
SWAP SortArray(Low), SortArray(High)
End If
Else
' Pick a pivot element at random, then move it to the end:
RandIndex = Rnd() * (High - Low) + Low ' RandInt%(Low, High)
SWAP SortArray(High), SortArray(RandIndex)
Partition = UCase(SortArray(High))
Do
' Move in from both sides towards the pivot element:
I = Low: J = High
Do While (I < J) And (UCase(SortArray(I)) <= Partition)
I = I + 1
Loop
Do While (J > I) And (UCase(SortArray(J)) >= Partition)
J = J - 1
Loop
' If we haven't reached the pivot element it means that 2
' elements on either side are out of order, so swap them:
If I < J Then
SWAP SortArray(I), SortArray(J)
End If
Loop While I < J
' Move the pivot element to its proper place in the array:
SWAP SortArray(I), SortArray(High)
' Recursively call the QuickSort procedure (pass the
' smaller subdivision first to use less stack space):
If (I - Low) < (High - I) Then
QuickSort SortArray, Low, I - 1
QuickSort SortArray, I + 1, High
Else
QuickSort SortArray, I + 1, High
QuickSort SortArray, Low, I - 1
End If
End If
End If
End Sub
Private Sub ScanFoldersC(cD As Integer)
Dim subFolders As Integer
Dim tL As String
Dim J As Integer
Dim I As Long
tL = ""
For J = 0 To File1.ListCount - 1
DoEvents
tL = tL & Space(cD * 5) + File1.List(J) & nL
Next
DS = DS & tL
subFolders = Dir2.ListCount
If subFolders > 0 Then
For I = 0 To subFolders - 1
DoEvents
DS = DS & "{\b " & DbS(Dir2.List(I)) & "}" & nL
File1.path = Dir2.List(I)
ChDir CurDir 'Dir2.List(i)
Dir2.path = Dir2.List(I)
Call ScanFoldersC(cD + 1)
Next
DoEvents
End If
' MoveUp
If Dir2.List(-1) <> InF Then
ChDir Dir2.List(-2)
Dir2.path = Dir2.List(-2)
End If
File1.path = Dir2.path
End Sub
Private Sub ScanFoldersD(path$, cD As Integer)
Dim tL As String ' temporary buffer for filenames
Dim tPath As String ' temporary path string
Dim I As Integer ' loop index
Dim sd$(0 To 100) ' array of subdirectories
Dim nDir As Integer ' # of subdirectories in sd$
Dim sf() As String ' array of files in directory
Dim nFile As Integer ' # of files in sf
ReDim sf(1 To 256)
tL = ""
nDir = 0
nFile = 0
sd$(0) = Dir$(".", vbDirectory)
While sd$(nDir) <> ""
If (GetAttr(sd$(nDir)) And vbDirectory) <> 0 Then
If Left$(sd$(nDir), 1) <> "." Then
nDir = nDir + 1
End If
Else
' add the item to the list
nFile = nFile + 1
sf(nFile) = sd$(nDir)
If nFile Mod 256 = 0 Then
ReDim Preserve sf(1 To UBound(sf) + 256)
End If
End If
sd$(nDir) = Dir()
Wend
nDir = nDir - 1
Call QuickSort(sd$, 0, nDir)
Call QuickSort(sf, 1, nFile)
For I = 1 To nFile
tL = tL & Space(cD * 5) + sf(I) & nL
Next I
DS = DS & tL
If nDir >= 0 Then
For I = 0 To nDir
tPath = path$ & "\" & sd$(I)
DS = DS & "{\b " & DbS(tPath) & "}" & nL
ChDir tPath
Call ScanFoldersD(tPath, cD + 1)
Next I
End If
End Sub
Private Sub SWAP(first As String, second As String)
Dim temp As String
temp = first
first = second
second = temp
End Sub
Private Sub Command1_Click()
InF = CurDir
MsgBox "This program is about to go through the entire " & InF & _
" ,please be patient."
DS = "{{\b " & DbS(Dir1.List(-1)) & "}" + nL
Call ScanFoldersC(1)
DS = DS & "}"
RichTextBox1.TextRTF = DS
End Sub
Private Sub Command2_Click()
InF = CurDir
MsgBox "This program is about to go through the entire " & InF & _
" ,please be patient."
DS = "{{\b " & DbS(InF) & "}" + nL
Call ScanFoldersD(InF, 1)
DS = DS & "}"
RichTextBox1.TextRTF = DS
End Sub
Private Sub Command3_Click()
RichTextBox1.TextRTF = ""
CommonDialog1.ShowOpen
If CommonDialog1.filename <> "" Then _
RichTextBox1.filename = CommonDialog1.filename
End Sub
Private Sub Command4_Click()
CommonDialog1.Filter = "*.RTF|*.RTF"
CommonDialog1.filename = ""
CommonDialog1.ShowSave
On Error Resume Next
If CommonDialog1.filename <> "" Then _
RichTextBox1.SaveFile CommonDialog1.filename
End Sub
Private Sub Dir1_Change()
File1.filename = Dir1.path
End Sub
Private Sub Drive1_Change()
Dir1.path = Drive1.Drive
End Sub
Private Sub Form_Load()
Dir1.Visible = False
Drive1.Visible = False
Dir2.Visible = False
File1.Visible = False
Form1.Visible = True
Command1.Caption = "Directory View Method A"
Command2.Caption = "Directory View Method B"
Command3.Caption = "Open"
Command4.Caption = "Save"
End Sub
185476 How To Search Directories to Find or List Files
185601 How To Recursively Search Directories Using FileSystemObject
Keywords: kbhowto kbctrl KB189631