Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''
Sub CreateList()
Dim FSO As Scripting.FileSystemObject
Dim TopFolderName As String
Dim DestCell As Range
Dim Fldr As Scripting.Folder
Dim TopFldr As Scripting.Folder
Dim Fi As Scripting.File
Dim Indent As Long
Dim ShowFiles As Boolean
Dim SortBy As Office.MsoSortBy
Dim SortOrder As Excel.XlSortOrder
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Setup Options
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Dim myDir As String, myList()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
TopFolderName = .SelectedItems(1)
End If
End With
On Error Resume Next
If Err = 0 Then
'TopFolderName = myDir 'change to top directory
Workbooks.Add ' Them file moi
Indent = 1 ' = 1 to ident in tree, = 0 for no indent
ShowFiles = True ' = true to list files, = false to list only folders
SortBy = msoSortByLastModified ' how to sort files
SortOrder = xlAscending ' sort order
Set DestCell = Range("A1") ' where to start tree
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False
Set FSO = New Scripting.FileSystemObject
DestCell.Value = TopFolderName
Set DestCell = DestCell(2, 1)
Set TopFldr = FSO.GetFolder(TopFolderName)
For Each Fldr In TopFldr.SubFolders
DoTree DestCell, Fldr, Indent, ShowFiles, SortBy, SortOrder
Next Fldr
If ShowFiles = True Then
Set DestCell = DestCell(2, Indent + 1)
DoFiles TopFldr, DestCell, SortBy, SortOrder
End If
Set FSO = Nothing
Else
MsgBox "No file found"
End If
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Private Sub DoTree(Rng As Range, Fldr As Scripting.Folder, _
Indent As Long, ShowFiles As Boolean, _
SortBy As MsoSortBy, SortOrder As Excel.XlSortOrder)
Dim F As Scripting.Folder
Rng(1, 1).Value = Fldr.Name
Rng(1, 1).NumberFormat = "General"
Rng(1, 1).Font.ColorIndex = 11
Rng(1, 1).Font.Bold = True
For Each F In Fldr.SubFolders
Set Rng = Rng(2, Indent + 1)
DoTree Rng, F, Indent, ShowFiles, SortBy, SortOrder
Set Rng = Rng(0, 1 - Indent)
Next F
If ShowFiles = True Then
Set Rng = Rng(2, Indent + 1)
DoFiles Fldr, Rng, SortBy, SortOrder
Set Rng = Rng(2, 1 - Indent)
Else
Set Rng = Rng(2, 1)
End If
End Sub
Private Sub DoFiles(F As Scripting.Folder, Rng As Range, _
SortBy As MsoSortBy, SortOrder As Excel.XlSortOrder)
Dim Fi As Scripting.File
Dim R1 As Range
Dim R2 As Range
Dim Key As Range
Set R1 = Rng
For Each Fi In F.Files
Rng(1, 1).Value = Fi.Name
Rng(1, 1).NumberFormat = "General"
Rng(1, 2).Value = Fi.DateLastModified
Rng(1, 2).NumberFormat = "dd-mmm-yyyy hh:mm:ss"
Rng(1, 3).Value = Fi.Size
Rng(1, 3).NumberFormat = "#,##0"
Rng(1, 4).Value = Fi.Type
Rng(1, 4).NumberFormat = "General"
Set Rng = Rng(2, 1)
Next Fi
Set R2 = Rng
Select Case SortBy
Case msoSortByFileName
Set Key = R1
Case msoSortBySize
Set Key = R1(1, 3)
Case msoSortByFileType
Set Key = R1(1, 4)
Case msoSortByLastModified
Set Key = R1(1, 2)
Case Else
End Select
If Not Key Is Nothing Then
Range(R1, R2).EntireRow.Sort key1:=Key, order1:=SortOrder
End If
End Sub
