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