Loop Through All Subfolders - VBA - Queue method - vba

Question

I've made use of Cor_blimey's queue method to write all the folders and subfolders of a drive to an excel sheet, as follows:
Public Sub NonRecursiveMethod()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("your folder path variable") 'obviously replace
Do While queue.Count > 0
Set oFolder = queue(queue.count)
queue.Remove(queue.count) 'dequeue
'...insert any folder processing code here...'
'*...(Here I write the name of the folder to the excel sheet)*.
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
'...insert any file processing code here...
Next oFile
Loop
End Sub
I've tried the "LIFO" version (as above) and the "FIFO" version, but neither of them produces a standard alphabetical listing. The above version lists the drive in exact reverse alphabetical order, and the "FIFO" version produces a list in normal alphabetical order, but it lists only the first-level folders, then starts again and lists all the second-level folders, again in alphabetical order, then the third level of folders, again starting over from "A", etc. As a result, the subfolders are not listed under their parent folder.
Does anyone know what I can do to get a standard tree structure, in alphabetical order by folder and subfolder name?
TIA
Les
Update: for some reason I can't manage to show all the comments on this thread or write a new comment. But I wanted to thank everybody, in particular #Rosenfeld, and say that I'm eager to try the solution using dir but am currently swamped with work. I'll report back in a few days when I get a chance to stumble around.

Answer 1

I'd like for the output to the sheet to look like the results of a tree command
Seems to me the simplest would be to just use the Tree command.
Here is one way, but the details could certainly be changed:
Execute a Tree command on the base folder
Write the output to some text file (location and name specified in the code)
Open the file as a text file in Excel
Split into columns on the vertical bar (Unicode character 9474) that the Tree command uses to differentiate levels
I use the WSH.Run method as that allows the CMD window to be easily hidden
One could use the WSH.Exec method to pipe the output directly to a VBA variable, but it is much harder to hide the CMD window (meaning, in another application, I've not been able to) :-)
One could also Import the text file into the same workbook instead of opening a new file. I will leave that exercise to you if you choose to do it.
Option Explicit
'set referennce to Windows Script Host Object Model
Sub DirTree()
Dim sBaseFolder As String, sTempFile As String
Dim WSH As WshShell
Dim sCMD As String
Dim lErrCode As Long
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\Tree.txt"
'Command line
sCMD = "CMD /c tree """ & sBaseFolder & """ > """ & sTempFile & """"
Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)
If Not lErrCode = 0 Then
MsgBox "Error in execution: Code - " & lErrCode
Else
'Open the file
Workbooks.OpenText Filename:=sTempFile, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
FieldInfo:=Array(Array(1, 1), Array(2, 1))
End If
End Sub
Here is a screenshot of the beginning of the output when run on my C: drive
EDIT: Since you now mention that you want the links to be clickable, an approach using dir would probably be simpler, especially since you can provide arguments to the dir command that will result in full paths being returned.
I used a class module so as to have a User Defined Object, which would have the necessary information; and a dictionary of these objects after appropriate filtering.
I chose to display merely the folder name in the cell, but the the screen tip will show the full path.
Note the References that need to be set (in the code). Also note that the class module must be renamed: cTree
EDIT 2: The Regular and Class modules were edited to allow for optional listing of the files. Note that the macro now has an argument, so it must be called from another macro or from the immediate window, to include the argument. (The argument could also be obtained from an Input box, user form, etc, but I did it this way for now because it is simpler.
I did not add hyperlinks for the files, thinking it would get confusing as different programs and dialogs (other than the file explorer) would be opening depending on the extension.
Class Module
Option Explicit
'Rename Class Module: cTree
Private pFullPath As String
Private pFolderName As String
Private pLevel As Long
Private pFile As String
Private pFiles As Dictionary
Public Property Get FullPath() As String
FullPath = pFullPath
End Property
Public Property Let FullPath(Value As String)
pFullPath = Value
End Property
Public Property Get FolderName() As String
FolderName = pFolderName
End Property
Public Property Let FolderName(Value As String)
pFolderName = Value
End Property
Public Property Get Level() As Long
Level = pLevel
End Property
Public Property Let Level(Value As Long)
pLevel = Value
End Property
Public Property Get Files() As Dictionary
Set Files = pFiles
End Property
Public Function ADDfile(Value As String)
pFiles.Add Value, Value
End Function
Private Sub Class_Initialize()
Set pFiles = New Dictionary
pFiles.CompareMode = TextCompare
End Sub
Regular Module
Option Explicit
'Set reference to Windows Script Host Object Model
' Microsoft Scripting Runtime
Sub GetDirList(bInclFiles As Boolean)
Const sDIRargs As String = " /A-S-L-H /S"
Dim sBaseFolder As String, sTempFile As String
Dim WSH As WshShell
Dim sCMD As String
Dim lErrCode As Long
Dim FSO As FileSystemObject, TS As TextStream
Dim S As String, sFN As String
Dim V As Variant, W As Variant
Dim I As Long
Dim lMaxLevel As Long
Dim lMinLevel As Long
Dim dctTrees As Dictionary, cT As cTree
Dim wsRes As Worksheet
Dim vRes As Variant, rRes As Range
'Add worksheet if needed
On Error Resume Next
Set wsRes = Worksheets("TreeLink")
If Err.Number = 9 Then
Set wsRes = Worksheets.Add
wsRes.Name = "TreeLink"
End If
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\DirList.txt"
'CommandLine
sCMD = "CMD /c dir """ & sBaseFolder & """" & sDIRargs & " > " & sTempFile
Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)
If Not lErrCode = 0 Then
MsgBox "Error in execution: Code - " & lErrCode
Stop
Else
'Read in the relevant data
Set dctTrees = New Dictionary
Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sTempFile, ForReading, False, TristateUseDefault)
lMaxLevel = 0
V = Split(TS.ReadAll, vbCrLf)
For I = 0 To UBound(V)
Do Until V(I) Like " Directory of *"
If I = UBound(V) Then Exit For
I = I + 1
Loop
Set cT = New cTree
S = Mid(V(I), 15)
'Can exclude certain directories at this point
'To exclude all that start with a dot:
If Not S Like "*\.*" Then
With cT
.FullPath = S
.FolderName = Right(S, Len(S) - InStrRev(S, "\"))
.Level = Len(S) - Len(Replace(S, "\", ""))
lMaxLevel = IIf(lMaxLevel > .Level, lMaxLevel, .Level)
dctTrees.Add Key:=S, Item:=cT
I = I + 1
'Only run for file list
If bInclFiles = True Then
Do
sFN = V(I)
If Not sFN Like "*<DIR>*" _
And sFN <> "" Then
'add the files
dctTrees(S).ADDfile Mid(sFN, 40)
End If
I = I + 1
Loop Until V(I) Like "*# File(s)*"
End If
End With
End If 'End of directory exclusion "if" statement
Next I
lMinLevel = dctTrees(dctTrees.Keys(0)).Level
I = 0
With rRes.Resize(columnsize:=lMaxLevel + 1).EntireColumn
.Clear
.HorizontalAlignment = xlLeft
End With
Application.ScreenUpdating = False
For Each V In dctTrees.Keys
Set cT = dctTrees(V)
With cT
I = I + 1
rRes.Worksheet.Hyperlinks.Add _
Anchor:=rRes(I, .Level - lMinLevel + 1), _
Address:="File:///" & .FullPath, _
ScreenTip:=.FullPath, _
TextToDisplay:=.FolderName
For Each W In .Files.Keys
I = I + 1
rRes(I, .Level - lMinLevel + 2) = W
Next W
End With
Next V
Application.ScreenUpdating = True
End If
End Sub
Results without File Listing
Results with File Listing

Answer 2

I know you are using a non-recursion method, but admittedly I wanted to try my hand at using recursion to solve the task (particularly for anyone who may need this in the future).
Note: I am not certain that the Scripting.FileSystem Folders/Files collections are always alphabetical so I am assuming they are in this case, but I could be mistaken.
From brief tests I am not noticing any kind of performance issue with recursion though, depending on the directory size, there certainly could be one.
Finally, the 'CleanOutput' argument in the main Function is used to determine if hierarchy relationships are displayed in the output.
Method Used to Test/Output
Sub Test()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Set Folder = fso.GetFolder("C:")
Dim Test As Variant
Test = GetDirectoryFromScriptingFolder(Folder, True)
ActiveSheet.Range("A1").Resize(UBound(Test, 1), UBound(Test, 2)).value = Test
End Sub
Main Function
Private Function GetDirectoryFromScriptingFolder(ByVal InputFolder As Scripting.Folder, Optional CleanOutput As Boolean = False) As Variant
' Uses recursion to return an organized hierarchy that represents files/folders in the input directory
Dim CurrentRow As Long
CurrentRow = 1
Dim CurrentColumn As Long
CurrentColumn = 1
Dim OutputDirectory As Variant
ReDim OutputDirectory(1 To GetDirectoryLength(InputFolder), 1 To GetDirectoryDepth(InputFolder))
WriteFolderHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn, CleanOutput
' Adjust current column so that files in the parent directory are properly indented
WriteFileHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn + 1, CleanOutput
GetDirectoryFromScriptingFolder = OutputDirectory
End Function
Functions Used in Recursion
Private Sub WriteFolderHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
If Not IsArray(InputHierarchy) Then Exit Sub
InputHierarchy(CurrentRow, CurrentColumn) = InputFolder.Name
CurrentRow = CurrentRow + 1
Dim StartRow As Long
Dim SubFolder As Folder
For Each SubFolder In InputFolder.SubFolders
' Use recursion to write the files/folders of each subfolder to the directory
StartRow = CurrentRow
WriteFolderHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 1, CleanOutput
WriteFileHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 2, CleanOutput
If CleanOutput Then
For StartRow = StartRow To CurrentRow
InputHierarchy(StartRow, CurrentColumn) = "||"
Next
End If
Next
End Sub
Private Sub WriteFileHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
If Not IsArray(InputHierarchy) Then Exit Sub
Dim SubFile As File
For Each SubFile In InputFolder.Files
' Write the Files to the Hierarchy
InputHierarchy(CurrentRow, CurrentColumn) = SubFile.Name
If CleanOutput Then InputHierarchy(CurrentRow, CurrentColumn - 1) = "--"
CurrentRow = CurrentRow + 1
Next
End Sub
Helper Functions (Depth and Length)
Private Function GetDirectoryLength(ByVal InputFolder As Scripting.Folder) As Long
Dim TotalLength As Long
' Include a base of 1 to account for the input folder
TotalLength = 1 + InputFolder.Files.Count
Dim SubFolder As Scripting.Folder
For Each SubFolder In InputFolder.SubFolders
' Add 1 to the total to account for the subfolder.
TotalLength = TotalLength + GetDirectoryLength(SubFolder)
Next
GetDirectoryLength = TotalLength
End Function
Private Function GetDirectoryDepth(ByVal InputFolder As Scripting.Folder) As Long
Dim TotalDepth As Long
Dim SubFolder As Scripting.Folder
Dim MaxDepth As Long
Dim NewDepth As Long
For Each SubFolder In InputFolder.SubFolders
NewDepth = GetDirectoryDepth(SubFolder)
If NewDepth > MaxDepth Then
MaxDepth = NewDepth
End If
Next
If MaxDepth = 0 Then MaxDepth = 1
' Add 1 for the Parent Directory
GetDirectoryDepth = MaxDepth + 2
End Function
What is essentially happening is this:
We take an input Folder and determine the dimensions of the hierarchy
for that file
Next, we define an output array using those dimensions.
Using a row counter and column counter, we allow the recursion functions to write their recursive results directly to the hierarchy
This hierarchy is returned, and the main routine puts this straight to the sheet
Next Steps that You Could Take
I noticed a few things doing this
There is no information other than the file name, which, depending on
the application, may make the method useless
All files are included
in the output, not just important ones (non-important files being
temp, hidden, etc.)
Even with the CleanOutput option there isn't an easy way of diagramming the relationships between parents and children.
Overall though this should suffice, depending on your needs. You can make adjustments as needed. If you have questions, just ask :).

Answer 3

I don't think LIFO or FIFO matters, just take a look at this idea.
Sub GetFilesInFolder(SourceFolderName As String)
'--- For Example:Folder Name= "D:\Folder Name\"
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
ii) User wants to get the list of all files inside a folder as well as Sub-folders
Copy and Paste the below Code and this will list down the list of all the files inside the folder as well as sub-folders. If there are other files which are there in some other Sub-folders then it will list down all files from each and Every Folders and Sub-folders.
Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)
'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
'Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
'--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.
If Subfolders = True Then
For Each SubFolder In SourceFolder.Subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
File Manager using Excel Macro in Excel Workbook
I have created one File Manager using the above Code. It basically fetches the list of Files from Folders and Sub-folders and list them. It fetches other details of the files as well like File Size, Last modified, path of the File, Type of the File and a hyperlink to open the file directly from the excel by clicking on that.
It looks something like below:
Here is the link to download the full Workbook.
http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/
Click on the button that is named 'Download Now'.