Option Explicit
Sub FolderInfo_Updated_2()
Dim _
FSO As Object, _
rCell As Range, _
lFoldersCount As Long, _
strInitialFolder As String, _
aryDataReturned() As Variant
strInitialFolder = BrowseForFolder
'// Bail if no folder chosen //
If strInitialFolder = CStr(False) Then Exit Sub
Application.ScreenUpdating = False
Worksheets.Add.Name = Format(Now, "mmmm dd yyyy h-mm AM/PM")
Set FSO = CreateObject("Scripting.FileSystemObject")
If MsgBox("Do you want to include subfolders ?", vbQuestion + vbYesNo) = vbYes Then
'// If user chooses to return subfolders, add the initial folder's subfolder //
'// count to the return of GetArraySize() //
lFoldersCount = FSO.GetFolder(strInitialFolder).SubFolders.Count _
+ GetArraySize(strInitialFolder, FSO)
'// Not sure this is the best way, but to size the return array from the next //
'// function, size and send empty array... //
ReDim aryDataReturned(1 To lFoldersCount, 1 To 6)
aryDataReturned = _
GetFolderInfo(FSO, strInitialFolder, lFoldersCount, True, aryDataReturned())
Else
lFoldersCount = FSO.GetFolder(strInitialFolder).SubFolders.Count
ReDim aryDataReturned(1 To lFoldersCount, 1 To 6)
aryDataReturned = _
GetFolderInfo(FSO, strInitialFolder, lFoldersCount, False, aryDataReturned())
End If
'// Plunk the returned array into resized range //
Range("A2").Resize(lFoldersCount, 6).Value = aryDataReturned
With Range("A1:F1")
.Value = Array("Folder", "Size in MB", "Date Created", _
"Last Accessed", "Last Modified", "Subfolders Count")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
'OR
'.ColumnWidth = Array(40, 15, 15, 15, 15, 15)
With .Offset(1, 1).Resize(lFoldersCount, .Columns.Count - 1)
.HorizontalAlignment = xlCenter
'// Rather than formatting the folder sizes as text, maybe just change what //
'// is displayed. This would seem easier to me, as for our next test. //
.Columns(1).NumberFormat = "#,##0.0"
For Each rCell In .Columns(1).Cells
If rCell.Value > 500 Then
rCell.Interior.Color = 65535
rCell.Font.Bold = True
End If
Next
End With
End With
Application.ScreenUpdating = True
End Sub
Function GetFolderInfo(FSO As Object, _
FolderSpec As String, _
RowCount As Long, _
ReturnSubDirs As Boolean, _
aryTemp() As Variant) As Variant()
Dim _
fsoFolder As Object, _
fsoSubFolder As Object, _
strFolSpec As String
Static i As Long
'On Error Resume Next
Set fsoFolder = FSO.GetFolder(FolderSpec)
For Each fsoSubFolder In fsoFolder.SubFolders
strFolSpec = FolderSpec & "\" & fsoSubFolder.Name
i = i + 1
aryTemp(i, 1) = fsoSubFolder.Path
aryTemp(i, 2) = fsoSubFolder.Size / 1048576
aryTemp(i, 3) = fsoSubFolder.DateCreated
aryTemp(i, 4) = fsoSubFolder.DateLastAccessed
aryTemp(i, 5) = fsoSubFolder.DateLastModified
aryTemp(i, 6) = fsoSubFolder.SubFolders.Count
'// See if user wants subfolders, recurse if true //
If ReturnSubDirs Then
GetFolderInfo FSO, strFolSpec, RowCount, True, aryTemp()
End If
Next
On Error GoTo 0
'// Again, not sure best way, but reset the Static var //
If i = RowCount Then
i = 0
End If
GetFolderInfo = aryTemp
End Function
Function GetArraySize(FolderSpec As String, _
FSO As Object, _
Optional CurrentCount As Long) As Long
Dim _
fsoFolder As Object, _
fsoSubFolder As Object, _
strFolSpec As String
Static lCnt As Long
Set fsoFolder = FSO.GetFolder(FolderSpec)
'// Resets lCnt //
lCnt = CurrentCount
For Each fsoSubFolder In fsoFolder.SubFolders
strFolSpec = FolderSpec & "\" & fsoSubFolder.Name
lCnt = lCnt + fsoSubFolder.SubFolders.Count
Call GetArraySize(strFolSpec, FSO, lCnt)
Next
GetArraySize = lCnt
End Function
Please note that the 'BrowseForFolder' is the same as you had in your last post.