VBA - Recursively list files and output to csv

omgrtm

New Member
Joined
Nov 16, 2009
Messages
2
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:
<!-- BEGIN TEMPLATE: bbcode_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
<!-- END TEMPLATE: bbcode_code -->
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)
<!-- END TEMPLATE: bbcode_code -->(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
 
Last edited:

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,551
Office Version
2013
Platform
Windows
I don't think I understand the merging of these two macros. All that needs to be modified is the output, which should be directed to a text file rather than excel. Since both these subs write output, they clearly don't mesh very well and are getting in each others way. I'd wipe the slate and start clean on this one. Doesn't the macro from vbaexpress do what you want? How about adding a counter and if the counter reaches 65,535 then switch to a new sheet?

(Note: as far as writing output to a text file, I'm not sure I'd use a csv file - or in any case, if you do, there's more rules involved than just adding commas. I.e, how to handle values that already have commas, which could be in a file name? Maybe a tab delimiter would be better).

What's your goal here? 65,000 filenames with attributes ... all I can think is your monitoring the filesystem for changes. Could there be a better utility already made for this?
 
Last edited:

omgrtm

New Member
Joined
Nov 16, 2009
Messages
2
Xenou,

You are right - I'm trying to do a little housekeeping here. I'd use dedicated utilities, but my workplace has many restrictions on the tools that are available to me (my other option was to use SAS to do it, but it would be too complicated to do it there).

As far as merging goes - I'm just taking bits from one code and adding them to the other; i'm not combining the two together in full. As for the comma separated values - I did have a problem but i later fixed it adding quotes around the entry:
"c:\temp","marley, me.jpg",..
So the csv file would work fine. Was a little dirty, but I worked it out in the end.

Finally, someone did spot error i had in the code - i'm dimming some vars both outside (public) and inside the sub (dim). The final code i used was:

Code:
Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil, f
 
Sub MainExtractData()
     
    Dim MainFolderName As String
    Dim TimeLimit As Long, StartTime As Double
    
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
         
    Set objShell = CreateObject("Shell.Application")
     
    Application.ScreenUpdating = False
    MainFolderName = "c:\temp" 'list files in this folder
    
    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
    
    Set f = FSO.OpenTextFile("c:\temp\output.csv", ForWriting, True)
    
    On Error Resume Next
    'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
    For Each Fil In oFolder.Files
        Set objFolder = objShell.Namespace(oFolder.path)
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        i = i + 1
        Application.StatusBar = "Files processed: " & i
        DoEvents
        
        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 = Chr(34) & d_path & Chr(34) & "," & Chr(34) & d_filename & Chr(34) & "," & d_dateaccess & "," & d_lastmod & "," & d_datecreate & "," & d_type & "," & d_size & "," & d_owner
        f.Writeline d_all 'write ob
    Next
     
    'Get subdirectories
    Call RecursiveFolder(oFolder)
    
FastExit:
    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)
    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
                  Application.StatusBar = "Files processed: " & i
                  DoEvents
                
                d_path = SubFld.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 = Chr(34) & d_path & Chr(34) & "," & Chr(34) & d_filename & Chr(34) & "," & 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)
    Next
End Sub
Thanks very much for your suggestions though, I appreciate it.

Cheers
Dan
 

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,551
Office Version
2013
Platform
Windows
I see - glad someone caught that! Makes more sense now.

ξ
 

Forum statistics

Threads
1,081,800
Messages
5,361,382
Members
400,629
Latest member
ganeshkhatri

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top