Excel VBA - Recursively list files and output to csv

Question

Hi guys,

I've got a problem with my VBA (you guessed it).

I took code from this post: vbaexpress.com/kb/getarticle.php?kb_id=405 and added in: wilmott.com/messageview.cfm?catid=10&threadid=40372

Basically, first code would output to a worksheet, but as I theoretically could breach the 65k rows limit, I'd like to output to a csv instead (i.e. write every line found out to an external text file). I don't really need the time limit functionality, i didn't get around to deleting that yet.

I'm running Excel 2003 SP2 on Windows XP Pro SP3. So the code that i have modified (combined version of the two above):

Code:

Public X() Public i As Long Public objShell, objFolder, objFolderItem Public FSO, oFolder, Fil

Sub MainExtractData() 

    Dim NewSht As Worksheet 
    Dim MainFolderName As String 
    Dim TimeLimit As Long, StartTime As Double 

    Const ForReading = 1, ForWriting = 2, ForAppending = 8 
    Dim FSO, f, g 

    ReDim X(1 To 65536, 1 To 11) 

    Set objShell = CreateObject("Shell.Application") 
    TimeLimit = 0 
    StartTime = Timer 

    Application.ScreenUpdating = False 
    MainFolderName = "c:\temp" 'list files in this folder
     ' Set NewSht = ThisWorkbook.Sheets.Add

     ' File attribs are as follows:
     ' X(1, 1) = "Path"
     ' X(1, 2) = "File Name"
     ' X(1, 3) = "Last Accessed"
     ' X(1, 4) = "Last Modified"
     ' X(1, 5) = "Created"
     ' X(1, 6) = "Type"
     ' X(1, 7) = "Size"
     ' X(1, 8) = "Owner"
     'X(1, 9) = "Author"
     'X(1, 10) = "Title"
     'X(1, 11) = "Comments"

    i = 1 

    Set FSO = CreateObject("scripting.FileSystemObject") 
    Set oFolder = FSO.GetFolder(MainFolderName) 
     'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
    On Error Resume Next 

    Set f = FSO.OpenTextFile("c:\temp\ls_output.csv", ForWriting, True) 

    For Each Fil In oFolder.Files 
        Set objFolder = objShell.Namespace(oFolder.path) 
        Set objFolderItem = objFolder.ParseName(Fil.Name) 
        i = i + 1 
        If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then 
            Goto FastExit 
        End If 
        If i Mod 50 = 0 Then 
            Application.StatusBar = "Processing File " & i 
            DoEvents 
        End If 


        d_path = oFolder.path 
        d_filename = Fil.Name 
        d_dateaccess = Fil.DateLastAccessed 
        d_lastmod = Fil.DateLastModified 
        d_datecreate = Fil.DateCreated 
        d_type = Fil.Type 
        d_size = Fil.Size 
        d_owner = objFolder.GetDetailsOf(objFolderItem, 8) 
        d_all = d_path & "," & d_filename & "," & d_dateaccess & "," & d_lastmod & "," & d_datecreate & "," & d_type & "," & d_size & "," & d_owner 
        f.Writeline d_all 'write ob

    Next 

     'Get subdirectories
    If TimeLimit = 0 Then 
        Call RecursiveFolder(oFolder, 0) 
    Else 
        If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime) 
        f.Write d_all 'write ob
    End If 
FastExit: 
     ' Range("A:K") = X
     ' If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
     ' Range("A:K").WrapText = False
     ' Range("A:K").EntireColumn.AutoFit
     ' Range("1:1").Font.Bold = True
     ' Rows("2:2").Select
     ' ActiveWindow.FreezePanes = True
     ' Range("a1").Activate

    Set FSO = Nothing 
    Set objShell = Nothing 
    Set oFolder = Nothing 
    Set objFolder = Nothing 
    Set objFolderItem = Nothing 
    Set Fil = Nothing 
    Application.StatusBar = "" 
    Application.ScreenUpdating = True 
    f.Close 
End Sub 

Sub RecursiveFolder(xFolder, TimeTest As Long) 
    Dim SubFld 

    For Each SubFld In xFolder.SubFolders 
        Set oFolder = FSO.GetFolder(SubFld) 
        Set objFolder = objShell.Namespace(SubFld.path) 
        For Each Fil In SubFld.Files 
            Set objFolder = objShell.Namespace(oFolder.path) 
             'Problem with objFolder at times
            If Not objFolder Is Nothing Then 
                Set objFolderItem = objFolder.ParseName(Fil.Name) 
                i = i + 1 
                If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then 
                    Exit Sub 
                End If 
                If i Mod 50 = 0 Then 
                    Application.StatusBar = "Processing File " & i 
                    DoEvents 
                End If 
                d_path = oFolder.path 
                d_filename = Fil.Name 
                d_dateaccess = Fil.DateLastAccessed 
                d_lastmod = Fil.DateLastModified 
                d_datecreate = Fil.DateCreated 
                d_type = Fil.Type 
                d_size = Fil.Size 
                d_owner = objFolder.GetDetailsOf(objFolderItem, 8) 

                d_all = d_path & "," & d_filename & "," & d_dateaccess & "," & d_lastmod & "," & d_datecreate & "," & d_type & "," & d_size & "," & d_owner & "," 
                f.Writeline d_all 'write ob
            Else 
                Debug.Print Fil.path & " " & Fil.Name 
            End If 

        Next 
        Call RecursiveFolder(SubFld, TimeTest) 
    Next 
End Sub

What i'm actually after is - files in the current directory (c:\temp) to be listed recursively (i.e. i also want files from subfolders), with their attributes (date modified, file owner etc) - output into a comma separated file (to be used elsewhere).

What this code actually does is list the files (and attribs) in the current folder, and closes the file. After inserting some breaks it seems that it jumps from this line

Code: Set oFolder = FSO.GetFolder(SubFld)(RecursiveFolder sub) back to a previous sub where the call to recursivefolder came from. This is weird as it does not happen in the original piece of code. Feel there's a schoolboy error in there somewhere!

Any help is greatly appreciated.

Cheers Dan