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:

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,827
Office Version
  1. 2019
Platform
  1. 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
Joined
Mar 2, 2007
Messages
16,827
Office Version
  1. 2019
Platform
  1. Windows
I see - glad someone caught that! Makes more sense now.

ξ
 

Watch MrExcel Video

Forum statistics

Threads
1,129,553
Messages
5,636,989
Members
416,953
Latest member
broexc

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top