A better way of listing folders (and subfolders) contents?

[sark666]

I need to list the folder contents of a drive that's very large. I was doing it previously from a dos prompt and just outputing the file names but I need to automate this and I need the created and modified date.
This lead me to using the Scripting.FileSystemObject. This example seems to make the rounds on numerous sites:

Sub ListFiles()
    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    
    'Declare the variable
    Dim objFSO As FileSystemObject
    
    'Insert the headers for Columns A through F
    Range("A1").Value = "File Name"
    Range("B1").Value = "File Size"
    Range("C1").Value = "File Type"
    Range("D1").Value = "Date Created"
    Range("E1").Value = "Date Last Accessed"
    Range("F1").Value = "Date Last Modified"
    
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Call the RecursiveFolder routine
    Call RecursiveFolder(objFSO, "C:\Users\Domenic\Documents", True)
    
    'Change the width of the columns to achieve the best fit
    Columns.AutoFit
    
End Sub
Sub RecursiveFolder( _
    FSO As FileSystemObject, _
    MyPath As String, _
    IncludeSubFolders As Boolean)
    'Declare the variables
    Dim File As File
    Dim Folder As Folder
    Dim SubFolder As Folder
    Dim NextRow As Long
    
    'Find the next available row
    NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    'Get the folder
    Set Folder = FSO.GetFolder(MyPath)
    
    'Loop through each file in the folder
    For Each File In Folder.Files
        Cells(NextRow, "A").Value = File.Name
        Cells(NextRow, "B").Value = File.Size
        Cells(NextRow, "C").Value = File.Type
        Cells(NextRow, "D").Value = File.DateCreated
        Cells(NextRow, "E").Value = File.DateLastAccessed
        Cells(NextRow, "F").Value = File.DateLastModified
        NextRow = NextRow + 1
    Next File
    
    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each SubFolder In Folder.SubFolders
            Call RecursiveFolder(FSO, SubFolder.Path, True)
        Next SubFolder
    End If
    
End Sub

It works, however on a large drive (100,000 + files) it really bogs down and excel shows 'not responding' numerous times and sometimes it doesn't seem like it'll go to completion. Sometimes it's done in about 40 minutes, other times I've left it over an hour and it's still running (while showing not responding).
I'm sure if it's because of numerous calls to vbscript? I read doevents could help this but I tried that within the subfolder check and it didn't seem to help.
Is this unavoidable simply due to the size and amount of sub-folders? If doevents can help here, I'm not really sure on how to use it and it's appropriate place in the code.

Using my dos method of simply outputting the contents to a file works much more efficently but I need to do two passes to capture created and then modified and then I would need to match up the files created and modified and the drive contents could potentially change between two passes.

And just to mention, I did a test on sub directory of this drive (that had about 12 folders with each containing roughly 10 folders in each) and it didn't take too long to complete (about 10 minutes) but again showed not responding numerous times. Doesn't that mean there's something hanging the vba code? I assume it's the vbscript calls.

 

[shg]

This listed 8000 files in less than a minute for me.

Sub ListFiles()</SPAN>
    Const sRoot     As String = "C:\Documents and Settings\shg\My Documents\"</SPAN>
    Dim oFSO        As Scripting.FileSystemObject</SPAN>
 
    Application.ScreenUpdating = False</SPAN>
    Columns("A:F").ClearContents</SPAN>
    Range("A1:F1").Value = Split("File Name,File Size,File Type,Date Created," & _</SPAN>
                                 "Date Last Accessed,Date Last Modified", ",")</SPAN>
    Set oFSO = New Scripting.FileSystemObject</SPAN>
    RecurseFolder oFSO, sRoot, True</SPAN>
    Columns.AutoFit</SPAN>
    Application.ScreenUpdating = True</SPAN>
End Sub</SPAN>
 
Sub RecurseFolder(oFSO As FileSystemObject, _</SPAN>
                  sDir As String, _</SPAN>
                  IncludeSubFolders As Boolean)</SPAN>
    Dim oFil        As File</SPAN>
    Dim oFld        As Folder</SPAN>
    Dim oSub        As Folder</SPAN>
    Dim iRow        As Long</SPAN>
 
    iRow = Cells(Rows.Count, "A").End(xlUp).Row + 1</SPAN>
    Set oFld = oFSO.GetFolder(sDir)</SPAN>
 
    For Each oFil In oFld.Files</SPAN>
        With oFil</SPAN>
            Rows(iRow).Range("A1:F1").Value = Array(.Name, .Size, .Type, _</SPAN>
                                                    .DateCreated, .DateLastAccessed, _</SPAN>
                                                    .DateLastModified)</SPAN>
            iRow = iRow + 1</SPAN>
        End With</SPAN>
    Next oFil</SPAN>
 
    If IncludeSubFolders Then</SPAN>
        For Each oSub In oFld.SubFolders</SPAN>
            RecurseFolder oFSO, oSub.Path, True</SPAN>
        Next oSub</SPAN>
    End If</SPAN>
End Sub</SPAN>

 

[sark666]

Thanks for this. But I get similar results as to with the previous method I was using. It only took about a minute or two with 2000 thousands files, but while processing I was getting the 'not responding' in the menu bar. Do you get that? I think that causes more of an issue when dealing with large (100,000 files) that might slow it down or cause it to crash. When dealing with the large dir it takes anywhere from 45 minutes to seemingly not completing.

I don't like the idea of the recursive macro. Isn't that considered bad programming? Just wondering if that's causing the 'not responding' issue. I tried to make one main macro call the first one and if need be call a second one for sub dir's, but it only grabbed the first sub dir and wouldn't continue on with additional sub dir's within the 2nd sub dir.

 

[shg]

Do you get that?

No, but I only listed 8000 files.

I don't like the idea of the recursive macro. Isn't that considered bad programming?

I don't think recursion is good or bad, it's just a method, and always a choice -- it's never required. You have to pay modest attention to recursion depth to avoid running out of stack space, but that's not likely to happen here.

Here's one without recursion. It listed 94,000 files in 72s on my less-than-heroic laptop, about 1500 files per second.

Sub ListFiles()</SPAN>
    Const sRoot     As String = "C:\"</SPAN>
    Dim t As Date</SPAN>
   
    Application.ScreenUpdating = False</SPAN>
    With Columns("A:C")</SPAN>
        .ClearContents</SPAN>
        .Rows(1).Value = Split("File,Date,Size", ",")</SPAN>
    End With</SPAN>
   
    t = Timer</SPAN>
    NoCursing sRoot</SPAN>
    Columns.AutoFit</SPAN>
    Application.ScreenUpdating = True</SPAN>
    MsgBox Format(Timer - t, "0.0s")</SPAN>
End Sub</SPAN>
 
Sub NoCursing(ByVal sPath As String)</SPAN>
    Const iAttr     As Long = vbNormal + vbReadOnly + _</SPAN>
          vbHidden + vbSystem + _</SPAN>
          vbDirectory</SPAN>
    Dim col         As Collection</SPAN>
    Dim iRow        As Long</SPAN>
    Dim jAttr       As Long</SPAN>
    Dim sFile       As String</SPAN>
    Dim sName       As String</SPAN>
 
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"</SPAN>
 
    Set col = New Collection</SPAN>
    col.Add sPath</SPAN>
 
    iRow = 1</SPAN>
 
    Do While col.Count</SPAN>
        sPath = col(1)</SPAN>
 
        sFile = Dir(sPath, iAttr)</SPAN>
 
        Do While Len(sFile)</SPAN>
            sName = sPath & sFile</SPAN>
 
            On Error Resume Next</SPAN>
            jAttr = GetAttr(sName)</SPAN>
            If Err.Number Then</SPAN>
                Debug.Print sName</SPAN>
                Err.Clear</SPAN>
 
            Else</SPAN>
                If jAttr And vbDirectory Then</SPAN>
                    If Right(sName, 1) <> "." Then col.Add sName & "\"</SPAN>
                Else</SPAN>
                    iRow = iRow + 1</SPAN>
                    If (iRow And &H3FF) = 0 Then Debug.Print iRow</SPAN>
                    Rows(iRow).Range("A1:C1").Value = Array(sName, _</SPAN>
                                                            FileLen(sName), _</SPAN>
                                                            FileDateTime(sName))</SPAN>
                End If</SPAN>
            End If</SPAN>
            sFile = Dir()</SPAN>
        Loop</SPAN>
        col.Remove 1</SPAN>
    Loop</SPAN>
End Sub</SPAN>

 

[sark666]

Awesome. thanks! I'm a little busy with something at work but I'll try this out shortly. Although I suspect the recursion isn't the issue going from the experience on your end. Although I'm glad to see working code with sub dir's without recursion because it was bugging me that I couldn't get it working right.

I meant even with 2000 files I get the not responding issue. maybe I should mention this drive is on a network and that could be causing the issue? Although I doubt it, because on this same drive I query hundrends of access databases via excel and never get that.

I'm trying still putting doevents in suspect spots to prevent this but that seems to cause issues as well.

Maybe I'm wrong but if not responding periodically comes up (even though code runs to completion) that to me means something is wrong behind the scenes. In this case I suspect resources are being exhausted, but then again, I get it with even 2000 files. I'm going to try a large local drive as well to see if it is the network.

If it is the network, I guess vbscript doesn't have any wait/respond conditions?

 

[shg]

Do-over:

Sub ListFiles()</SPAN>
    Const sRoot     As String = "C:\"</SPAN>
    Dim t As Date</SPAN>
   
    Application.ScreenUpdating = False</SPAN>
    With Columns("A:C")</SPAN>
        .ClearContents</SPAN>
        .Rows(1).Value = Split("File,date,size", ",")</SPAN>
    End With</SPAN>
   
    t = Timer</SPAN>
    NoCursing sRoot</SPAN>
    Columns.AutoFit</SPAN>
    Application.ScreenUpdating = True</SPAN>
    MsgBox Format(Timer - t, "0.0s")</SPAN>
End Sub</SPAN>
 
Sub NoCursing(ByVal sPath As String)</SPAN>
    Const iAttr     As Long = vbNormal + vbReadOnly + _</SPAN>
          vbHidden + vbSystem + _</SPAN>
          vbDirectory</SPAN>
    Dim col         As Collection</SPAN>
    Dim iRow        As Long</SPAN>
    Dim jAttr       As Long</SPAN>
    Dim sFile       As String</SPAN>
    Dim sName       As String</SPAN>
 
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"</SPAN>
 
    Set col = New Collection</SPAN>
    col.Add sPath</SPAN>
 
    iRow = 1</SPAN>
 
    Do While col.Count</SPAN>
        sPath = col(1)</SPAN>
 
        sFile = Dir(sPath, iAttr)</SPAN>
 
        Do While Len(sFile)</SPAN>
            sName = sPath & sFile</SPAN>
 
            On Error Resume Next</SPAN>
            jAttr = GetAttr(sName)</SPAN>
            If Err.Number Then</SPAN>
                Debug.Print sName</SPAN>
                Err.Clear</SPAN>
 
            Else</SPAN>
                If jAttr And vbDirectory Then</SPAN>
                    If Right(sName, 1) <> "." Then col.Add sName & "\"</SPAN>
                Else</SPAN>
                    iRow = iRow + 1</SPAN>
                    If (iRow And &HFFF) = 0 Then Debug.Print iRow</SPAN>
                    Rows(iRow).Range("A1:C1").Value = Array(sName, _</SPAN>
                                                            FileDateTime(sName), _</SPAN>
                                                            FileLen(sName))</SPAN>
                End If</SPAN>
            End If</SPAN>
            sFile = Dir()</SPAN>
        Loop</SPAN>
        col.Remove 1</SPAN>
    Loop</SPAN>
End Sub</SPAN>

 

[sark666]

Thanks again for your updated code. Much appreciated. As I suspected though, recursion isn't causing the not responding issue. It finished quick enough: 2000 files in 14 seconds. I tired a local folder with 21,000 files and it finished quickly as well but still got the not responding with both tests. I was hoping/thinking maybe it was network timeouts behind the scenes and it wouldn't happen with a local drive.

Even though it finishes quickly on this sample, I think whatever is causing the not responding issue grows as the files/directories grow. Normally I don't even look at spec's of a machine when dealing iwth excel. I'm working on someone's work laptop right now and it's a intel core i3-2350M @ 2.3 GHZ with 4 gigs of ram, running windows 7, office 2010. I was using this laptop specifically for office 2010 as I knew I'd run into the row limit on 2003. But I'm going to run a sample on 2003 just to see if the not responding happens as well.

Which version of office are you running? Do you agree that not responding usually indicates a resource issue (that excel is close to falling over). For the most part it completes, but takes a really long time on the large directories. I'll run it again with your update to get an exact figure of how long it takes. Maybe I'll have to ignore it in the end, but I've written some things in the past that deal with numerous remote files and I've never had not responding issues.

 

[Kyle123]

Not responding simply means that Excel is busy, on some computers code takes longer to execute than others depending on available resources, network speed etc, it doesn't mean Excel is close to falling over. That's all.

Not responding will last longer as directories grow since Excel has more files to process so will take longer, you're processing a huge amount of files so not responding in this scenario is perfectly normal. DoEvents could stop this, but could make your code execute more slowly.

Out of curiosity, what do you have against recursion? I can think of scenarios that would be nigh on impossible without it (or would be so inefficient that they cease to become feasible)

 

[shg]

It finished quick enough: 2000 files in 14 seconds.

That's a small fraction of the speed I'm getting on my three year old laptop running XP and Excel 2003/07/10 (1500 files/s)

DoEvents could stop this, but could make your code execute more slowly.

What Kyle said. I'm not that impatient that I can't wait 90s to list all the files on my laptop, but do understand if it's taking many times that long.

I can think of scenarios that would be nigh on impossible without recursion

E.g., ?

 

[Kyle123]

E.g., ?

Getting all user details within nested email distribution lists of unknown depths from the AD?

Actually navigating hierarchical data structures of unknown depth in general