Results 1 to 7 of 7

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

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Regular
    Joined
    Jan 2015
    Posts
    15
    Location

    Display a list of the folders and subfolders in VBA

    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 
    
    
    Last edited by dm28949; 01-30-2015 at 12:04 PM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •