Excel

List File Attributes of Directory and Subdirectores

Ease of Use

Easy

Version tested with

2000, 2003 

Submitted by:

brettdj

Description:

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. 

Discussion:

You want a list of file attributes in an Excel table as you prefer a list to using Windows tools to filter file attributes. 

Code:

instructions for use

			

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

How to use:

  1. Copy the code above.
  2. Open your workbook.
  3. Hit Alt+F11 to open the Visual Basic Editor (VBE).
  4. From the menu, choose Insert-Module.
  5. Paste the code into the code window at right.
  6. Close the VBE, and save the file if desired.
 

Test the code:

  1. Run the macro by going to Tools-Macro-Macros and double-click MainExtractData
 

Sample File:

FileAtt(KB17).zip 20.6KB 

Approved by mdmackillop


This entry has been viewed 414 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express