Display a list of the folders and subfolders in VBA

**dm28949** · 01-30-2015, 09:17 AM

First time posting in this forum!!! I found a KB entry by brettdj in this forum that lists the file atrributes of folders and subfolders. What I want to do is list the properties of folders and subfoldes in high level not the files contained in the subfolders. I would appreciate any help on how to do that.

For example:
Main folder: Database
Folders contained by main folder: SQL, Access, Oracle
Folders contained by SQL: Data2010, Data 2011 etc
Folders contained by Access: A, B, C, D, E etc
Is it possible to list just the properties of SQL, Access and oracle but not the folders inside of them?

I am absolutely new to programming and struggling to get this done.

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

**Bob Phillips** · 01-30-2015, 10:04 AM

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 6)

    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()
    If MainFolderName <> "" Then

        Set NewSht = ThisWorkbook.Sheets.Add
        
        X(1, 1) = "Path"
        X(1, 2) = "Last Accessed"
        X(1, 3) = "Last Modified"
        X(1, 4) = "Created"
        X(1, 5) = "Size"
        X(1, 6) = "IsRootFolder"
        
        i = 1
        
        Set FSO = CreateObject("scripting.FileSystemObject")
        Set oFolder = FSO.GetFolder(MainFolderName)
        
        i = i + 1
        X(i, 1) = oFolder.Path
        X(i, 2) = oFolder.DateLastAccessed
        X(i, 3) = oFolder.DateLastModified
        X(i, 4) = oFolder.DateCreated
        X(i, 5) = oFolder.Size
        X(i, 6) = oFolder.IsRootFolder
        
        '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:F") = X
        If i < Rows.Count - 1 Then Range(Cells(i + 1, "A"), Cells(Rows.Count, "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
    End If
    
    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)
        
        i = i + 1
        X(i, 1) = oFolder.Path
        X(i, 2) = oFolder.DateLastAccessed
        X(i, 3) = oFolder.DateLastModified
        X(i, 4) = oFolder.DateCreated
        X(i, 5) = oFolder.Size
        X(i, 6) = oFolder.IsRootFolder
        
        Call RecursiveFolder(SubFld, TimeTest)
    Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim foldername As String

    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .AllowMultiSelect = False
        If .Show = -1 Then
        
            BrowseForFolder = .SelectedItems(1)
        End If
    End With

End Function

**dm28949** · 02-02-2015, 08:18 AM

How do I convert the size to say KB?

**dm28949** · 02-02-2015, 08:23 AM

How do I convert the size to say KB?

Also, I only want to access the folders to certain level. I wanna access subfolders and the folders contained by subfolders not the hundreds of folders inside of them.

**Bob Phillips** · 02-02-2015, 04:05 PM

KB - divide by 1000.

If you want at a certain level, add a public vraiant to count each call and when it exceeds your designated level number, exit immediately.

**snb** · 02-03-2015, 01:47 AM

Sub M_snb()
  With CreateObject("wscript.shell")
    For Each it In Array("SQL", "Access", "Oracle")
      c00 = c00 & vbCrLf & "G:\Database\" & it & Replace(.exec("cmd /c Dir G:\Database\" & it & "*.* /b").stdout.readall, vbCrLf, vbCrLf & "G:\Database\" & it) & "|"
    Next
  End With
  
  sn = filter(Filter(Split(c00, vbCrLf), "|", False),"\")
  ReDim sp(UBound(sn), 10)
    
  With CreateObject("scripting.filesystemobject")
    For j = 0 To UBound(sn)
        With .getfile(sn(j))
        sp(j, 0) = sn(j)
        sp(j, 1) = .Parent
        sp(j, 2) = .Name
        sp(j, 3) = FileDateTime(sn(j))
        sp(j, 4) = .DateLastModified
        sp(j, 5) = .DateCreated
        sp(j, 6) = .Type
        sp(j, 7) = FileLen(sn(j))
    Next
 
    sheet1.cells(1).resize(Ubound(sp)+1,ubound(sp,2)+1)=sp  
End Sub

More on fileproperties:

http://www.snb-vba.eu/VBA_Bestanden_en.html

**dm28949** · 02-03-2015, 07:10 AM

Thank you very much. This forum is awesome!

Thread: Display a list of the folders and subfolders in VBA

Thread Tools

Display

Display a list of the folders and subfolders in VBA

Tags for this Thread

Posting Permissions