Option Explicit
Dim Directory_List() As String
Dim Total_Number_Of_Directories As Double
Dim Current_Directory As Double
Private Function Get_Available_Drives(Drive_List() As String) As Long
On Error Resume Next
Dim Current_Drive As Long
Dim File_System_Object As Object
Set File_System_Object = CreateObject("Scripting.FileSystemObject")
Dim Drive As Object, Computer As Object
Set Computer = File_System_Object.Drives
For Each Drive In Computer
'If it's not a disk drive and if it's a removable
'hard drive or a fixed drive... I needed
'Drive.DriveType <> 1 so the computer doesn't
'load the disk drive on the part where it says
'Drive.IsReady. Dead give away somethings going
'on.
If Drive.DriveType <> 1 And (Drive.DriveType = 2 Or Drive.DriveType = 3) Then
'Is the drive ready?
If Drive.IsReady Then
Current_Drive = Current_Drive + 1
ReDim Preserve Drive_List(Current_Drive) As String
Drive_List(Current_Drive) = Drive.Path & "\"
End If
End If
Next
Get_Available_Drives = Current_Drive
'If no drive exists then terminate.
If Current_Drive = 0 Then End
End Function
Private Sub Recurse_Directory_List(Directory_Path As String)
On Error Resume Next
Dim File_System_Object As Object
Dim Directory As Object
Dim Get_Directory_Path As Object
Dim Sub_Directory As Object
Set File_System_Object = CreateObject("Scripting.FileSystemObject")
Set Get_Directory_Path = File_System_Object.GetFolder(Directory_Path)
Set Sub_Directory = Get_Directory_Path.Subfolders
For Each Directory In Sub_Directory
DoEvents
Current_Directory = Current_Directory + 1
ReDim Preserve Directory_List(Current_Directory) As String
Directory_List(Current_Directory) = Directory & "\"
Recurse_Directory_List (Directory)
Next
End Sub
Private Sub Create_Directory_List(Drive As String, Directory_List() As String)
On Error Resume Next
ReDim Directory_List(0) As String
Current_Directory = Current_Directory + 1
ReDim Preserve Directory_List(Current_Directory) As String
Directory_List(Current_Directory) = Drive
Recurse_Directory_List Drive
Total_Number_Of_Directories = Current_Directory
Current_Directory = 0
End Sub
Public Sub Get_All_Directories()
On Error Resume Next
Dim Drive_List() As String
Dim Number_Of_Drives As Long
Dim Current_Drive As Long
Dim File_Path As String
Dim Directory_Path As String
Dim Get_Number_Of_Directories As Double
Dim Current_Sub_Directory As Double
Number_Of_Drives = Get_Available_Drives(Drive_List())
For Current_Drive = 1 To Number_Of_Drives
'The Create_Directory_List will take less than a minute. Has to scan ALL
'directories in the harddrive.
Create_Directory_List Drive_List(Current_Drive), Directory_List()
For Current_Sub_Directory = 1 To Total_Number_Of_Directories
Do
DoEvents
Current_Directory = Current_Directory + 1
Directory_Path = Directory_List(Current_Sub_Directory)
'You can do something like store them in a listbox
'List1.AddItem Directory_Path
Loop Until Current_Directory = (Get_Number_Of_Directories + Number_Of_Directories)
Current_Directory = 0
Next Current_Sub_Directory
Next Current_Drive
End Sub