Folder Size within a directory - tweak code

[bdsii]

I am hoping this is simple for our experts on here. I have borrowed the code below from others on this forum which pulls file data from a user selected directory. This code is awesome and works great for getting file info from directories and all subdirectories.

I hope to modify this code so it will provide FOLDER information, primarily the folder size, for every subfolder within the selected directory.

I tried tinkering with the code to substitute folder for file and had it so hosed up it would not function. I am hoping that someone here can help me change up some of the variables to make it work for bringing back the folder info instead of file info.

If it is possible, I would also like to have the user choose each time if the code should pull folder info for folders within the subfolders or just the folders within the selected directory only. The default choice should be pulling info from only the folders within the selected directory and not go further.

Any help you could provide would be appreciated. I would think this is something others could benefit from as well.


thanks !



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
' Commenting out line above prevented it from adding new sheet each time this ran. _
Now it runs and displays data on the same sheet you have active
X(1, 1) = "Path"
X(1, 2) = "Folder 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
FastExit:
Range("A:K") = X
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 (file://\\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

[mdmackillop]

Try


Option Explicit
Dim i

Sub test()
ShowFolderInfo ("C:\Test")
End Sub

Sub ShowFolderInfo(folderspec)
Dim fs, f, s, x
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
For Each s In f.subfolders
i = i + 1
x = folderspec & "\" & s.Name
Cells(i, 1) = x
Cells(i, 2) = s.Size
ShowFolderInfo x
Next
End Sub

[bdsii]

Thanks mdmackillop......the code is much shorter. I have been playing with it and it is causing me problems and locking up. I am going to try this at home tonight to see if it is a problem with this machine.

Is there a way to modify the code to allow the users to choose if they want only the folders selected rather than all subfolders within all the other folders?

Also, how can I edit this to use the BrowseForFolder macro above to allow the user to select the initial folder without changing the code ?


thanks !

[mdmackillop]

Add the BrowseForFolder function to this



Sub test()
ShowFolderInfo (BrowseForFolder)
End Sub


Sub ShowFolderInfo(folderspec)
Dim fs, f, s, x
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
For Each s In f.subfolders
i = i + 1
x = folderspec & "\" & s.Name
Cells(i, 1) = x
Cells(i, 2) = s.Size
' ShowFolderInfo x ' Comment out to omit recursive loop
Next
End Sub

[bdsii]

Thanks again mdmackillop.....I have taken the code you provided and tweaked it more to allow me to do what I needed. I have most everything working. Thanks to lucas I have it adding a spreadsheet and naming it the time and date in case the user needs to run several of these and keep them on different sheets.

I did find that I had to specify the value to start for the variable "i" or the variable would not reset to 0 if the macro is ran a second time. This would cause the data to start where the data left off from the first time. Once I set the value of "i", everything worked fine.

I have tried checking the size field for values over 500.0 and then formatting them to stand out. This portion did not work for some reason. It randomly highlighted differing values for size and did not highlight all values greater than 500.0.

Any idea why my code is doing that ? See below (full version is further down in case it helps anyone) :

This code is not working properly to highlight the size if it is over 500.0 ???????



' Highlights sizes over 500.0 MB
Counter = 2
For Counter = 2 To totalrows + 1
Range("B" & Counter).Activate
If ActiveCell.Value > "500.0" Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Else
' Do Nothing
End If
Counter = Counter + 1
Next Counter



FULL VERSION



Option Explicit
Dim i

Sub FolderInfo_Updated()
Dim NewName1 As String
Dim newname2 As String
NewName1 = Format(Now, "mmmm dd yyyy")
newname2 = Format(Now, "h-mm AM/PM")
Worksheets.Add
ActiveSheet.Name = NewName1 & " " & newname2
i = 1
Dim Response As VbMsgBoxResult
Response = MsgBox("Do you want to include subfolders ?", vbQuestion + vbYesNo)
If Response = vbNo Then
ShowFolderInfo_Single (BrowseForFolder)
Else
ShowFolderInfo_Recursive (BrowseForFolder)
End If
' After returning from processing data, spreadsheet is cleaned up and formatted
' Creates header row
Cells(1, 1) = "Folder"
Cells(1, 2) = "Size in MB"
Cells(1, 3) = "Date Created"
Cells(1, 4) = "Last Accessed"
Cells(1, 5) = "Last Modified"
Cells(1, 6) = "Subfolders Count"
' End creating header row
' calculates how many rows have data in the spreadsheet
Dim Counter As Long
Dim totalrows As Long
totalrows = ActiveSheet.UsedRange.Rows.Count
' Highlights sizes over 500.0 MB
Counter = 2
For Counter = 2 To totalrows + 1
Range("B" & Counter).Activate
If ActiveCell.Value > "500.0" Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Else
' Do Nothing
End If
Counter = Counter + 1
Next Counter
' Formats columns
Columns("A:A").ColumnWidth = 40
Columns("B:B").ColumnWidth = 15
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("C1").Select
Columns("C:C").ColumnWidth = 15
Columns("D:D").ColumnWidth = 15
Columns("E:E").ColumnWidth = 15
Columns("C:E").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("F1").Select
Columns("F:F").ColumnWidth = 15
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1:F1").Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Range("A1").Select
' End Formatting Columns
End Sub


Sub ShowFolderInfo_Single(folderspec)
Dim fs, f, s, x
Dim FolderSize As Single
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
For Each s In f.SubFolders
i = i + 1
x = folderspec & "\" & s.Name
Cells(i, 1) = s.Path
Cells(i, 2).Value = Format((s.Size / 1048576), "#,##0.0")
Cells(i, 3) = s.DateCreated
Cells(i, 4) = s.DateLastAccessed
Cells(i, 5) = s.DateLastModified
Cells(i, 6) = s.SubFolders.Count
' ShowFolderInfo x 'Comment out to omit recursive loop
Next
End Sub

Sub ShowFolderInfo_Recursive(folderspec)
Dim fs, f, s, x
Dim FolderSize As Single
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
For Each s In f.SubFolders
i = i + 1
x = folderspec & "\" & s.Name
Cells(i, 1) = s.Path
Cells(i, 2).Value = Format((s.Size / 1048576), "#,##0.0")
Cells(i, 3) = s.DateCreated
Cells(i, 4) = s.DateLastAccessed
Cells(i, 5) = s.DateLastModified
Cells(i, 6) = s.SubFolders.Count
ShowFolderInfo_Recursive x
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 (file://\\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

[bdsii]

I am still not sure what is wrong with the code above that does not highlight cells correctly where the size is greater than 500 MB. Any ideas ?

[GTO]

...I have tried checking the size field for values over 500.0 and then formatting them to stand out. This portion did not work for some reason. It randomly highlighted differing values for size and did not highlight all values greater than 500.0.

Any idea why my code is doing that ? See below (full version is further down in case it helps anyone) :



' Highlights sizes over 500.0 MB
Counter = 2
For Counter = 2 To totalrows + 1
'...Statements...
Counter = Counter + 1
Next Counter




Greetings,

I did not test well, but one thing spotted is where you are increasing the val of 'Counter'. Read the help topic reference For...Next, but in short, 'Counter' will increase by one ea loop by default. In the help topic, note the 'Step' argument.

You also have a lot of selecting and activating going on that is slower.

Here's a similar shot, though I chose to practice returning an array from the recursive function:


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.

Hope that helps,

Mark

[gautamvats47]

Hello Mark,

Thanks for the helpful code that you have created !!!

It works good. Can it also ask for the Folder ? like can it open a brouse window to select which folder to be selected for the code to run.

that would be quite helpful.

Thanks & Regards.
Gautam Sharma