List Files in directory

yasawa

New Member
Joined
Dec 29, 2011
Messages
21
Hello:

I got this code a long time ago (thx to who made it), it lists files in selected directory and its sub directories + some file properties
The problem is that it continues filling the the rest of the sheet with N/a values for 983050 rows (if this num. has a meaning), this turns xls file size from 32 KB to 32 MB...
How can i stop the macro when there are no more files to add to sheet, and hence the timer option will be useless?
Thanks



Option Explicit

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)

ReDim x(1 To 10000, 1 To 12)

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"
x(1, 12) = "Length"


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)
x(i, 12) = objFolder.GetDetailsOf(objFolderItem, 27)


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:L") = x
If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:L").WrapText = False
Range("A:L").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)
x(i, 12) = objFolder.GetDetailsOf(objFolderItem, 27)

Debug.Print x(i, 1), x(i, 2), x(i, 11)
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
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
I also have this code that do what i need and don't have the problem in the previous code, but doesn't provide as much info on file as the previous one


Sub ListFiles2()
Dim LastStartPoint As String
Dim directories() As String, CurrentDirectory As String
Dim DirCounter As Integer, DirValue As String
Dim filelist As Variant

On Error GoTo 0

ShowHiddenAndSystemFiles = MsgBox("Show HIDDEN and SYSTEM files?", vbYesNoCancel, "Hidden & system files")

' SelectedDir is a public variable set within the DisplayDirectoryDialogBox sub.
If ShowHiddenAndSystemFiles = vbCancel Then Exit Sub
StartPoint = SelectedDir

' Add a sheet to put the output on.
' It is labelled with the date and time so that it won't clash with other sheet names
UserForm2.LB_Directory.Caption = " Currently searching directory " & SelectedDir
Sheets.Add after:=Worksheets(1)
'ActiveSheet.Name = "Files " & Format(Now, "dd-mmm-yyyy hh-mm-ss AM/PM")
ActiveSheet.Name = "Files "
With Range("A1")
.FormulaR1C1 = "File Directory and Name"
.Offset(0, 1).Value = "File Size"
.Offset(0, 2).Value = "File Date & Time"
End With
Range("A:A").ColumnWidth = 70
Range("B:C").ColumnWidth = 30
Range("c:C").NumberFormat = "dd-mmm-yyyy hh:mm:ss AM/PM"
Range("c1").ColumnWidth = 30
Range("A2").Select
filelist = Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 2)).Value
ReDim directories(2)

' Add a backslah to the directory starting point if it was not entered.

If Right(StartPoint, 1) = "\" Then
directories(1) = StartPoint
Else
directories(1) = StartPoint & "\"
End If

directories(2) = ""

' initialise Directory counter

DirCounter = 1
FileCount = 0
On Error Resume Next

' Now loop through the directories() array.
' For each entry test whether it's a file or a directory.
' If it's a file then add it to the filelist() array.
' If it's a directory then add it to the directories() array.
' Keep going until there are no more entries in the directories array()!!

Do While directories(DirCounter) <> ""
CurrentDirectory = directories(DirCounter)

' use the DIR() function to get the first entry for the current directory

If ShowHiddenAndSystemFiles = vbYes Then
DirValue = Dir(CurrentDirectory, vbDirectory + vbHidden + vbSystem)
Else
DirValue = Dir(CurrentDirectory, vbDirectory)
End If

Do While DirValue <> ""

' write the file name sto the statusbar to show that something useful is happening

Application.StatusBar = CurrentDirectory & DirValue

If InStr("..", DirValue) = 0 Then

' Use the GetAttr() function to check whether the entry is a directory.
' it's a directory entry so check to see if it's "." or ".."
' these are returned by the DIR() function but should be ignored

dirok = GetAttr(CurrentDirectory & DirValue) And vbDirectory
If dirok Then

' Add one more line to the Directories() array and
' paste the text into the array.

ReDim Preserve directories(UBound(directories) + 1)
directories(UBound(directories) - 1) = CurrentDirectory & DirValue & "\"
Else

' must be a file so store the file name and it's attributes

FileCount = FileCount + 1
filelist(FileCount, 1) = CurrentDirectory & DirValue
filelist(FileCount, 2) = FileLen(CurrentDirectory & DirValue)
'Format(Now, "dd-mmm-yyyy hh-mm-ss AM/PM")
filelist(FileCount, 3) = Format(FileDateTime(CurrentDirectory & DirValue), "dd-mmm-yyyy hh:mm:ss AM/PM")

filelist(FileCount, 4) = CurrentDirectory & DirValue


SumDiskSpace = SumDiskSpace + filelist(FileCount, 2)
UserForm2.LB_FileNumber.Caption = " Number of files found is " & FileCount
UserForm2.LB_Space.Caption = " Disk space currently used is " & Int(SumDiskSpace / 100000) / 10 & " MB"
Application.StatusBar = "Space so far is " & SumDiskSpace
If Int(FileCount / 10) * 10 = FileCount Then
UserForm2.Image1.Visible = Not UserForm2.Image1.Visible
UserForm2.Image2.Visible = Not UserForm2.Image1.Visible
End If
DoEvents
End If
End If

' get the next value fron the DIR() function

DirValue = Dir()
Loop
DirCounter = DirCounter + 1

Loop

Range(ActiveCell, ActiveCell.End(xlDown).Offset(0, 2)).Value = filelist
Application.StatusBar = False

End Sub
 
Upvote 0
Made some minor changes to the code from your first post, it seems to work fine now. I adjusted the range in which values are pasted, and used a redim preserve statement on "x".

Code:
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)

 ReDim x(1 To 12, 1 To 1)

 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(2, 1) = "File Name"
 x(3, 1) = "Last Accessed"
 x(4, 1) = "Last Modified"
 x(5, 1) = "Created"
 x(6, 1) = "Type"
 x(7, 1) = "Size"
 x(8, 1) = "Owner"
 x(9, 1) = "Author"
 x(10, 1) = "Title"
 x(11, 1) = "Comments"
 x(12, 1) = "Length"


 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
  ReDim Preserve x(1 To 12, 1 To i)
 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(1, i) = oFolder.Path
 x(2, i) = Fil.Name
 x(3, i) = Fil.DateLastAccessed
 x(4, i) = Fil.DateLastModified
 x(5, i) = Fil.DateCreated
 x(6, i) = Fil.Type
 x(7, i) = Fil.Size
 x(8, i) = objFolder.GetDetailsOf(objFolderItem, 8)
 x(9, i) = objFolder.GetDetailsOf(objFolderItem, 9)
 x(10, i) = objFolder.GetDetailsOf(objFolderItem, 10)
 x(11, i) = objFolder.GetDetailsOf(objFolderItem, 14)
 x(12, i) = objFolder.GetDetailsOf(objFolderItem, 27)

Next Fil
 '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(Cells(1, 1), Cells(i, 12)) = Application.Transpose(x)
 'If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
 Range("A:L").WrapText = False
 Range("A:L").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)
 x(i, 12) = objFolder.GetDetailsOf(objFolderItem, 27)

 Debug.Print x(i, 1), x(i, 2), x(i, 11)
 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
 
Upvote 0
it's working fine when there are no sub directories, I edited the sub directory SUB as follows (to match with your edits), but still not working for sub directories:



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

x(12, i) = objFolder.GetDetailsOf(objFolderItem, 27)

Debug.Print x(1, i), x(2, i), x(11, i)
Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next

Call RecursiveFolder(SubFld, TimeTest)
Next

End Sub
 
Upvote 0
Replace the RecursiveFolder sub with this one:
Code:
 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
  ReDim Preserve x(1 To 12, 1 To i)
 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(1, i) = oFolder.Path
 x(2, i) = Fil.Name
 x(3, i) = Fil.DateLastAccessed
 x(4, i) = Fil.DateLastModified
 x(5, i) = Fil.DateCreated
 x(6, i) = Fil.Type
 x(7, i) = Fil.Size
 x(8, i) = objFolder.GetDetailsOf(objFolderItem, 8)
 x(9, i) = objFolder.GetDetailsOf(objFolderItem, 9)
 x(10, i) = objFolder.GetDetailsOf(objFolderItem, 10)
 x(11, i) = objFolder.GetDetailsOf(objFolderItem, 14)
 x(12, i) = objFolder.GetDetailsOf(objFolderItem, 27)

 Debug.Print x(1, i), x(2, i), x(11, i)
 Else
 Debug.Print Fil.Path & " " & Fil.Name
 End If
 Next
 Call RecursiveFolder(SubFld, TimeTest)
 Next
 End Sub

It works here, let me know if it does the trick.
 
Upvote 0
Thanks a lot, works fine

Here is the whole code in case anybody needs it

Option Explicit

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 12, 1 To 1)

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(2, 1) = "File Name"
x(3, 1) = "Last Accessed"
x(4, 1) = "Last Modified"
x(5, 1) = "Created"
x(6, 1) = "Type"
x(7, 1) = "Size"
x(8, 1) = "Owner"
x(9, 1) = "Author"
x(10, 1) = "Title"
x(11, 1) = "Comments"
x(12, 1) = "Length"


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
ReDim Preserve x(1 To 12, 1 To i)
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(1, i) = oFolder.Path
x(2, i) = Fil.Name
x(3, i) = Fil.DateLastAccessed
x(4, i) = Fil.DateLastModified
x(5, i) = Fil.DateCreated
x(6, i) = Fil.Type
x(7, i) = Fil.Size
x(8, i) = objFolder.GetDetailsOf(objFolderItem, 8)
x(9, i) = objFolder.GetDetailsOf(objFolderItem, 9)
x(10, i) = objFolder.GetDetailsOf(objFolderItem, 10)
x(11, i) = objFolder.GetDetailsOf(objFolderItem, 14)
x(12, i) = objFolder.GetDetailsOf(objFolderItem, 27)

Next Fil
'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(Cells(1, 1), Cells(i, 12)) = Application.Transpose(x)
'If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
Range("A:L").WrapText = False
Range("A:L").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
ReDim Preserve x(1 To 12, 1 To i)
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(1, i) = oFolder.Path
x(2, i) = Fil.Name
x(3, i) = Fil.DateLastAccessed
x(4, i) = Fil.DateLastModified
x(5, i) = Fil.DateCreated
x(6, i) = Fil.Type
x(7, i) = Fil.Size
x(8, i) = objFolder.GetDetailsOf(objFolderItem, 8)
x(9, i) = objFolder.GetDetailsOf(objFolderItem, 9)
x(10, i) = objFolder.GetDetailsOf(objFolderItem, 10)
x(11, i) = objFolder.GetDetailsOf(objFolderItem, 14)
x(12, i) = objFolder.GetDetailsOf(objFolderItem, 27)

Debug.Print x(1, i), x(2, i), x(11, i)
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
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

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
Back
Top