List of Files in Directory - Almost works

[bdsii]

I used the excellent article in the link below to help create a macro for Excel 2007 to create a list of files in a directory. I followed the directions included and it worked......almost. :(

well, cannot post a link until I have 5 posts...anyway the Article was referenced in previous posts and attributed by Lucas. It is called "List File Attributes of Directory and Subdirectores" -
This code prompts the user to browse for a folder. It then uses recursive code to dump all the file attributes of this folder ("Path", "Last Modified" , "Owner" , "Size" , "Comments" etc ), and any subfolders to a new Excel sheet. see end for code....

The only problem is that for some reason after the last file info has been written into Excel, it fills the remaining columns and rows with #N/A.

I am new to VB and cannot determine why this is happening. I tried uploading the resulting xls file but without luck. I hope I have explained this well enough to allow someone here to help me with a solution.

Thanks in advance!


Code provided by the article referenced above.



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

ReDim X(1 To 65536, 1 To 11)

Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" _
& vbNewLine & vbNewLine & _
"Leave this at zero for unlimited runtime", "Time Check box", 0)
StartTime = Timer

Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add

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
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
X(i, 1) = oFolder.path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next

'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
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
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
X(i, 1) = SubFld.path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Else
Debug.Print Fil.path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld, TimeTest)
Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error Goto 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then Goto Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then Goto Invalid
Case Else
Goto Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

[rbrhodes]

Hi bds,


May be an Excel 2007 thing?? (Lucas might know but I don't)

but comment out the line marked in the snippet below:



Sub MainExtractData()

<SNIP>



FastExit:
Range("A:K") = X

'//Comment out or delete this line

'If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete

'//End

"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
End Sub

[GTO]

Greetings bdsii,

I believe I found the KB article you referred to (authored by brettdj) here:

http://www.vbaexpress.com/kb/getarticle.php?kb_id=405

You may wish to also check...

http://www.vbaexpress.com/forum/showthread.php?t=26569

...as it appears that changing the row limit worked.

As I hadn't yet found that last thread, and wasn't sure about sizing the array to rows.count, here is what I had come up with.

It takes a little longer, as it makes an initial run thru all the folder to get a file count, but the array is then just sized as big as needed. Not sure, but I think that would work?

Anyways, I also noted that certain properties, notably the Title in my case, could glitch if (when planted on the worksheet) Excel construed as a formula. I simply changed the columns number format to text and no longer had any issues.

I would note that I couldn't duplicate the problem you mentioned for some reason, even when I was sure (sorta) that I was dumping empty elements on the sheet (and not deleting the rows).


Option Explicit

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

'//Added to count all the files in all the sub-directories of the folder we start at. //
Dim lCount As Long

Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double

'// Changed/Added
'ReDim X(1 To 65536, 1 To 11)
Dim lMainCount As Long

Set objShell = CreateObject("Shell.Application")
TimeLimit = Application.InputBox("Please enter the maximum time that you wish " & _
"this code to run for in minutes" & vbNewLine & _
vbNewLine & "Leave this at zero for " & _
"unlimited runtime", "Time Check box", 0)
StartTime = Timer

Application.ScreenUpdating = False
MainFolderName = BrowseForFolder()
Set NewSht = ThisWorkbook.Sheets.Add

Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)

'// Added: lCount=0 isn't necessary, just explicit. lMainCount adds the number //
'// of files found in the starting folder to the return of RecurseFolder //
lCount = 0
lMainCount = oFolder.Files.Count + RecurseFolder(oFolder, 0) + 1

'// With Excel 2007 having about one-bajillion and thirty-seven rows, I wasn't sure //
'// about making the array based on Rows.Count. So... Changed to sizing the array //
'// based on the total number of files. //
ReDim X(1 To lMainCount, 1 To 11)

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

'error handling to stop the obscure error that occurs at time when retrieving
' DateLastAccessed
On Error Resume Next
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
X(i, 1) = oFolder.Path
X(i, 2) = Fil.Name
X(i, 3) = Fil.DateLastAccessed
X(i, 4) = Fil.DateLastModified
X(i, 5) = Fil.DateCreated
X(i, 6) = Fil.Type
X(i, 7) = Fil.Size
X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next

'Get subdirectories
If TimeLimit = 0 Then
Call RecursiveFolder(oFolder, 0)
Else
If Timer < (TimeLimit * 60 + StartTime) _
Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
End If

FastExit:

'// I found that in one case, a .doc I had started with a copied formula had picked //
'// up part of formula as the Title. This in turn seemed to goober stuff up (the //
'// array built fine of course, but from that element and on, nothing would get //
'// get planted into the worksheet). Changing the format to Text before planting //
'// seems to handle fine. //
Range("A:K").EntireColumn.NumberFormat = "@"

Range("A1:K" & lMainCount).Value = X

'// No longer used //
'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
End Sub

'//*************************************************************//
'// Add a function based on brettdj's previous work //
'//*************************************************************//
Function RecurseFolder(xFolder, TimeTest As Long) As Long
Dim SubFld

For Each SubFld In xFolder.SubFolders
lCount = lCount + SubFld.Files.Count
Call RecurseFolder(SubFld, TimeTest)
Next
RecurseFolder = lCount
End Function


Please note that the other two functions are still req'd; as there was no changes to them, I just didn't see re-including.

After reading the last thread referred to, you may well wish to simply substitute Rows.Count everywhere you find 65536 in the original code. I do think changing the number format to text helped.

Hope that helps,

Mark

[Dave]

Perhaops the DIR function will work in 07? Dave
edit: I removed my code as it wasn't quite right

[bdsii]

Thanks all for helping. I tried a couple of different approaches I wanted to share.

rbrhodes suggested I comment out the line below and I got this to work in Excel 2007.
'If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete

I also changed the row count from 65535 to the Excel 2007 count of 1048576 as noted in the Article link posted above by GTO. This worked as well.

GTO - I liked your idea to do an initial run through the folders to get a file count but I could not get it to work. I think it has something to do with the line below or not but it seemed to be the cause of the error. I am just learning VB so I could not debug it. I think RecurseFolder should be RecursiveFolder but I am not sure. I tried replacing it with RecursiveFolder but still got an error so I am not sure I have that right.
lMainCount = oFolder.Files.Count + RecurseFolder(oFolder, 0) + 1
If you could look at that and let me know if you could find the error I would like to use your option.

Thanks to everyone. I am gonna love this forum :-)

[GTO]

I also changed the row count from 65535 to the Excel 2007 count of 1048576 as noted in the Article link posted above by GTO. This worked as well.


GTO - I liked your idea to do an initial run through the folders to get a file count but I could not get it to work. I think it has something to do with the line below or not but it seemed to be the cause of the error. I am just learning VB so I could not debug it. I think RecurseFolder should be RecursiveFolder but I am not sure. I tried replacing it with RecursiveFolder but still got an error so I am not sure I have that right.
lMainCount = oFolder.Files.Count + RecurseFolder(oFolder, 0) + 1
If you could look at that and let me know if you could find the error I would like to use your option.

Hi,

Hopefully I am not posting this twice, as I have no idea what keys I just hit and everything seemed to go bye-bye...

Okay, 'RecurseFolder' is a Function to run thru all the subfolders, adding the .Files.Count in in ea folder to lCount, to eventually return the total count all the files in the subfolders, whereas brettdj's 'RecursiveFolder' is a Sub that goes thru all the folders, and adds ea file's name and various properties to an array.

Thus, to use my suggestion you need to copy the code I posted, plus the Sub 'RecursiveFolder' and the Function 'BrowseForFolder' from your first post. My bad, as I probably shouldn't have named the Function so closely to the original Sub.

I believe it should work fine then, as although I am limited to Excel 2003 and haven't tested in 2007, I don't see anything that can go Kaboom! in it.

That said, of course rbrhodes suggestion or the suggestion to use 2007's row counts certainly are good.

You mention learning (which of course we are all), so I would again offer the suggestion (if simply updating to the new 1048576 rows, to use Rows.Count instead. So:

ReDim X(1 To 65536, 1 To 11)

...would become...

ReDim X(1 To Rows.Count, 1 To 11)


...and so on in the sub. The reason for this suggestion is is makes the code "self-adjusting" and can run in either 2007 or previous versions.

Well, I hope that helps a bit,

Mark

[bdsii]

Thanks GTO....will give it a try and let you know :-)

[starcrwzr]

I'm new to the forum and somewhat new to VBA, and I've discovered a bug with "Files in Directory". I've installed the macro and tried it on a network folder on our LAN and what it returned was a file listing, missing some of the files. There are 209 files in the directory but the macro only returned 161. When I looked at the list, it became obvious what was missing, all the files with a .ZIP extension were not present.

I can't see anything in the code that looks at file extensions, so what's happening?

Scott B)