Code to List the files in all the subfolders

superfb

Board Regular
Joined
Oct 5, 2011
Messages
121
Hi All,

So i have a VBA code that lists the number of files in a specific directory

However, can this VBA code be evolved to have the following,

1) List the number of folders and Sub-folders
2) List all the files in these folders and sub folder

Would be beneficial if the each Macro provides a message box to show the number of folders brought back and for the second macro brings back a message box to show the number of files in the directory (brought back)

Code:
Option Explicit


Sub Get_Files_Information()


Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")


Dim FSO As New FileSystemObject
Dim fo As folder
Dim f As File
Dim FileItem As Scripting.File
Set fo = FSO.GetFolder(sh.Range("B3").Value)


Dim last_row As Integer


For Each f In fo.Files
     last_row = sh.Range("A" & Application.Rows.Count).End(xlUp).Row + 1
     sh.Range("A" & last_row).Value = f.Name
     sh.Range("d" & last_row).Value = f.Path
     sh.Range("C" & last_row).Value = f.Type
    sh.Range("G" & last_row).Select
     'sh.Range("D" & last_row).Value = f.DateLastModified
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        f.Path, TextToDisplay:="Click Here to Open"




Next




MsgBox "Action completed"


End Sub
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.

bobsan42

Well-known Member
Joined
Jul 14, 2010
Messages
1,394
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2013
Platform
  1. Windows
Generally to go into the sub-folder you need to use recursion - the code must call itself again to go deeper.
I just answered a similar question here: Code to List the files in all the subfolders

This is something I made for myself and it works for me. Paste it in a module and run the first SUB. This is the complete module with several functions inside. See the result and decide if you want to use it:
Code:
Option Explicit
Option Compare Text
Option Base 1


'Public Const App_Title = "File scanner 42"
Const FirstCol = "A"
Private cRow As Long 'current row - increasing with every new record
Private cRng As Range 'current cell - increasing with every new record
Private ScannedSize As Variant 'running sum of scanned files


Sub t42_ScanFilesAndFolders()
    On Error GoTo ErrHandler
    
'Select folder to be scanned
    Dim root As String: root = BrowseForFolder
    If UCase(root) = "FALSE" Then Exit Sub 'if no folder is selected
    If Left(root, 2) = "\\" Then MsgBox "Cannot scan network drives yet!", vbOKOnly: Exit Sub
    
    If Right(root, 1) <> "\" Then root = root & "\" 'make sure we have \ at the end
    Dim AbsLevel As Long: AbsLevel = UBound(Split(root, "\")) - 1 'directory depth of root in the drive
    Dim RL As Long: RL = 0 'relative directory level - root=0
    Dim scanTime As String: scanTime = Format(Now(), "yyyymmdd-hhmmss")
    Dim drv As String: drv = Left(root, 1)
    Dim drvFree As Variant: drvFree = DrvGetFreeSpace(drv)
    Dim drvFull As Variant: drvFull = DrvGetOccupiedSpace(drv)
    Dim drvTotal As Variant: drvTotal = drvFree + drvFull
    Dim ColHeaders As String: ColHeaders = "Object,Name,Extension,Type,Size,Full path,Parent folder,Relative level,Attributes,Date created,Date Modified,Date accessed"
    
    Dim i As Long, j As Long
'    Stop
    Dim wb As Workbook
    If Not ActiveWorkbook Is Nothing Then
        Set wb = ActiveWorkbook
        i = 1
    Else
        Set wb = Workbooks.Add
        i = 0
    End If
    
    Dim wsh As Worksheet
    With wb
        If i = 1 Then
            Set wsh = .Worksheets.Add(, .Worksheets(.Worksheets.Count))
        Else
            Set wsh = .ActiveSheet
        End If
    End With
    
    wsh.Name = "Scan " & scanTime
    wsh.Activate
    
    Dim rng As Range: Set rng = wsh.Range("A1")
    Dim rngDur As Range
    Dim VarTime As Variant
    i = 0
    With rng
        .Value = "Scan time:"
        .Offset(, 1) = scanTime
        i = i + 1
        .Offset(i, 0).Value = "Selected drive:"
        .Offset(i, 1).Value = drv
        i = i + 1
        .Offset(i, 0).Value = "Capacity:"
        .Offset(i, 1).Value = Round(drvTotal / 1024 ^ 3, 3) & " GB"
        .Offset(i, 2).Value = drvTotal
        .Offset(i, 2).NumberFormat = "#,##0"
        With .Offset(i, 4)
            .Value = "Folder(s) count:"
            .HorizontalAlignment = xlRight
            .Interior.Color = 65535
            .Font.Bold = True
            With .Offset(, 1)
                .FormulaR1C1 = "=COUNTIF(C[-5],""Folder"")"
                .HorizontalAlignment = xlLeft
                .InsertIndent 1
            End With
        End With
        i = i + 1
        .Offset(i, 0).Value = "Free space:"
        .Offset(i, 1).Value = Round(drvFree / 1024 ^ 3, 3) & " GB"
        .Offset(i, 2).Value = drvFree
        .Offset(i, 2).NumberFormat = "#,##0"
        With .Offset(i, 4)
            .Value = "File(s) count:"
            .HorizontalAlignment = xlRight
            .Interior.Color = 65535
            .Font.Bold = True
            With .Offset(, 1)
                .FormulaR1C1 = "=COUNTIF(C[-5],""File"")"
                .HorizontalAlignment = xlLeft
                .InsertIndent 1
            End With
        End With
        i = i + 1
        .Offset(i, 0).Value = "Occupied space:"
        .Offset(i, 1).Value = Round(drvFull / 1024 ^ 3, 3) & " GB"
        .Offset(i, 2).Value = drvFull
        .Offset(i, 2).NumberFormat = "#,##0"
                With .Offset(i, 4)
            .Value = "Scanned size:"
            .HorizontalAlignment = xlRight
            .Interior.Color = 65535
            .Font.Bold = True
            With .Offset(, 1)
                .FormulaR1C1 = "=SUBTOTAL(9,C[-1])"
                .NumberFormat = "#,##0"
                .HorizontalAlignment = xlRight
'                .InsertIndent 1
                .Offset(, 1).FormulaR1C1 = "=ROUND(C[-1]/1024^3,3)"
                .Offset(, 2).Value = "GB"
            End With
        End With


        i = i + 1
        .Offset(i, 0).Value = "Selected folder:"
        .Offset(i, 1).Value = root
        If Len(root) > 3 Then
            .Offset(i, 2).Value = FldGetFolderSize(root)
            .Offset(i, 2).NumberFormat = "#,##0"
        End If
        i = i + 1
        .Offset(i, 0).Value = "Root level:"
        .Offset(i, 1).Value = AbsLevel
        i = i + 1
        .Offset(i, 0).Value = "Scan duration:"
        Set rngDur = .Offset(i, 1)
        .Offset(i, 2) = "seconds"
        
        Range(.Address & ":" & .Offset(i, 1).Address).Interior.Color = 65535
        Range(.Address & ":" & .Offset(i, 0).Address).Font.Bold = True
        Range(.Address & ":" & .Offset(i, 0).Address).HorizontalAlignment = xlRight
        Range(.Address & ":" & .Offset(i, 0).Address).InsertIndent 1
        Range(.Offset(0, 1).Address & ":" & .Offset(i, 1).Address).HorizontalAlignment = xlLeft
        
        i = i + 3
    End With
    
    wsh.Columns("A:B").EntireColumn.AutoFit
    
    Set cRng = wsh.Range(FirstCol & i)
    
    With cRng.Resize(1, UBound(Split(ColHeaders, ",")) + 1)
        .Cells = Split(ColHeaders, ",")
        .Interior.Color = 65535
        .Font.Bold = True
    End With
    Set cRng = cRng.Offset(1)
    cRng.Select
    DoEvents
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
'Start scanning
    VarTime = VBA.DateTime.Timer
    Call checkSubfolders42(root, 0)
    rngDur.Value = VBA.DateTime.Timer - VarTime
    
    With wsh
        .Columns("A:E").EntireColumn.AutoFit
        .Columns("H:L").EntireColumn.AutoFit
        .Columns("F:F").ColumnWidth = .Columns("C:C").ColumnWidth
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    wb.Activate
    
    If wb.Path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else wb.Save
    
exitPoint:
    On Error Resume Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    Set wb = Nothing
    Set wsh = Nothing
    Set rng = Nothing
    Set rngDur = Nothing
    Set cRng = Nothing
    
    drvFree = Null
    drvFull = Null
    drvTotal = Null
    ScannedSize = Null
    cRow = 0
    VarTime = Null
    
    Exit Sub
    
ErrHandler:
    MsgBox "An error occurred." & vbCrLf & _
            "Number: " & Err.Number & vbCrLf & _
            "Description: " & Err.Description & vbCrLf & _
            "Error line: " & Erl, vbOKOnly


End Sub


Function BrowseForFolder(Optional OpenAt As Variant = 17) 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


    
'Table 12-4 Constants for the Third Parameter of BrowseForFolder*
'
'Constant Description
'&H0001  Only file system folders can be selected. If this bit is set, the OK button is disabled if the user selects a folder that doesn't belong to the file system (such as the Control Panel folder).
'&H0002  The user is prohibited from browsing below the domain within a network (during a computer search).
'&H0004  Room for status text is provided under the text box. (I haven't found a way to show the status, however.)
'&H0008  Returns file system ancestors only.
'&H0010  Shows an edit box in the dialog box for the user to type the name of an item.
'&H0020  Validate the name typed in the edit box.
'&H1000  Enables the user to browse the network branch of the shell's namespace for computer names.
'&H2000  Enables the user to browse the network branch of the shell's namespace for printer names.
'&H4000  Allows browsing for everything.
'
    'iOptions [in]
    'Type: Integer
    'An Integer value that contains the options for the method.
    'This can be zero or a combination of the values listed under the ulFlags member of the BROWSEINFO structure.
        'Flags that specify the options for the dialog box. This member can be 0 or a combination of the following values. Version numbers refer to the minimum version of Shell32.dll required for SHBrowseForFolder to recognize flags added in later releases. See Shell and Common Controls Versions for more information.
        '
        'BIF_RETURNONLYFSDIRS (0x00000001)
        '0x00000001. Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
        'Note  The OK button remains enabled for "\\server" items, as well as "\\server\share" and directory items. However, if the user selects a "\\server" item, passing the PIDL returned by SHBrowseForFolder to SHGetPathFromIDList fails.
        '
        'BIF_DONTGOBELOWDOMAIN (0x00000002)
        '0x00000002. Do not include network folders below the domain level in the dialog box's tree view control.
        '
        'BIF_STATUSTEXT (0x00000004)
        '0x00000004. Include a status area in the dialog box. The callback function can set the status text by sending messages to the dialog box. This flag is not supported when BIF_NEWDIALOGSTYLE is specified.
        '
        'BIF_RETURNFSANCESTORS (0x00000008)
        '0x00000008. Only return file system ancestors. An ancestor is a subfolder that is beneath the root folder in the namespace hierarchy. If the user selects an ancestor of the root folder that is not part of the file system, the OK button is grayed.
        '
        'BIF_EDITBOX (0x00000010)
        '0x00000010. Version 4.71. Include an edit control in the browse dialog box that allows the user to type the name of an item.
        '
        'BIF_VALIDATE (0x00000020)
        '0x00000020. Version 4.71. If the user types an invalid name into the edit box, the browse dialog box calls the application's BrowseCallbackProc with the BFFM_VALIDATEFAILED message. This flag is ignored if BIF_EDITBOX is not specified.
        '
        'BIF_NEWDIALOGSTYLE (0x00000040)
        '0x00000040. Version 5.0. Use the new user interface. Setting this flag provides the user with a larger dialog box that can be resized. The dialog box has several new capabilities, including: drag-and-drop capability within the dialog box, reordering, shortcut menus, new folders, delete, and other shortcut menu commands.
        'Note  If COM is initialized through CoInitializeEx with the COINIT_MULTITHREADED flag set, SHBrowseForFolder fails if BIF_NEWDIALOGSTYLE is passed.
        '
        'BIF_BROWSEINCLUDEURLS (0x00000080)
        '0x00000080. Version 5.0. The browse dialog box can display URLs. The BIF_USENEWUI and BIF_BROWSEINCLUDEFILES flags must also be set. If any of these three flags are not set, the browser dialog box rejects URLs. Even when these flags are set, the browse dialog box displays URLs only if the folder that contains the selected item supports URLs. When the folder's IShellFolder::GetAttributesOf method is called to request the selected item's attributes, the folder must set the SFGAO_FOLDER attribute flag. Otherwise, the browse dialog box will not display the URL.
        '
        'BIF_USENEWUI
        'Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE.
        'Note  If COM is initialized through CoInitializeEx with the COINIT_MULTITHREADED flag set, SHBrowseForFolder fails if BIF_USENEWUI is passed.
        '
        'BIF_UAHINT (0x00000100)
        '0x00000100. Version 6.0. When combined with BIF_NEWDIALOGSTYLE, adds a usage hint to the dialog box, in place of the edit box. BIF_EDITBOX overrides this flag.
        '
        'BIF_NONEWFOLDERBUTTON (0x00000200)
        '0x00000200. Version 6.0. Do not include the New Folder button in the browse dialog box.
        '
        'BIF_NOTRANSLATETARGETS (0x00000400)
        '0x00000400. Version 6.0. When the selected item is a shortcut, return the PIDL of the shortcut itself rather than its target.
        '
        'BIF_BROWSEFORCOMPUTER (0x00001000)
        '0x00001000. Only return computers. If the user selects anything other than a computer, the OK button is grayed.
        '
        'BIF_BROWSEFORPRINTER (0x00002000)
        '0x00002000. Only allow the selection of printers. If the user selects anything other than a printer, the OK button is grayed.
        'In Windows XP and later systems, the best practice is to use a Windows XP-style dialog, setting the root of the dialog to the Printers and Faxes folder (CSIDL_PRINTERS).
        '
        'BIF_BROWSEINCLUDEFILES (0x00004000)
        '0x00004000. Version 4.71. The browse dialog box displays files as well as folders.
        '
        'BIF_SHAREABLE (0x00008000)
        '0x00008000. Version 5.0. The browse dialog box can display sharable resources on remote systems. This is intended for applications that want to expose remote shares on a local system. The BIF_NEWDIALOGSTYLE flag must also be set.
        '
        'BIF_BROWSEFILEJUNCTIONS (0x00010000)
        '0x00010000. Windows 7 and later. Allow folder junctions such as a library or a compressed file with a .zip file name extension to be browsed.




'Table 12-5 Constants for the Fourth Parameter of BrowseForFolder
'
'Constant Description
'0   The Desktop (virtual) folder is the root directory. Using this constant along with &H0001 for the third parameter circumvents problems with the OK button.
'1   Internet Explorer is the root.
'2   The Programs folder of the Start menu is the root.
'3   The Control Panel folder is the root. The third parameter must be set to &H4000 (browse for everything).
'4   The Printers folder is the root. The third parameter must be set to &H4000 (browse for everything).
'5   The Documents folder of the Start menu is the root.
'6   The Favorites folder of the Start menu is the root.
'7   The Startup folder of the Start menu is the root. The third parameter must be set to &H4000 (browse for everything).
'8   The Recent folder is the root. The third parameter must be set to &H4000 (browse for everything).
'9   The SendTo folder is the root. The third parameter must be set to &H4000 (browse for everything).
'10  The Recycle Bin folder is the root. The third parameter must be set to &H4000 (browse for everything).
'11  The Start menu folder is the root.
'16  The Desktop (physical) folder is the root.
'17  My Computer is the root.
'18  Network Neighborhood is the root.
'19  The Nethood folder is the root.
'20  The Fonts folder is the root.
'21  The Templates folder is the root.




'' More Values for the OpenAt parameter:
    'vRootFolder [in, optional]
    'Type: Variant
    'The root folder to use in the dialog box.
    'The user cannot browse higher in the tree than this folder.
    'If this value is not specified, the root folder used in the dialog box is the desktop.
    'This value can be a string that specifies the path of the folder or one of the ShellSpecialFolderConstants values.
    'Note that the constant names found in ShellSpecialFolderConstants are available in Visual Basic, but not in VBScript or JScript.
    'In those cases, the numeric values must be used in their place.
        'Constants
        'ssfDESKTOP  0x00 (0). Windows desktop—the virtual folder that is the root of the namespace.
        'ssfPROGRAMS 0x02 (2). File system directory that contains the user's program groups (which are also file system directories). A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\Start Menu\Programs.
        'ssfCONTROLS 0x03 (3). Virtual folder that contains icons for the Control Panel applications.
        'ssfPRINTERS 0x04 (4). Virtual folder that contains installed printers.
        'ssfPERSONAL 0x05 (5). File system directory that serves as a common repository for a user's documents. A typical path is C:\Users\username\Documents.
        'ssfFAVORITES    0x06 (6). File system directory that serves as a common repository for the user's favorite URLs. A typical path is C:\Documents and Settings\username\Favorites.
        'ssfSTARTUP  0x07 (7). File system directory that corresponds to the user's Startup program group. The system starts these programs whenever any user first logs into their profile after a reboot. A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\StartUp.
        'ssfRECENT   0x08 (8). File system directory that contains the user's most recently used documents. A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\Recent.
        'ssfSENDTO   0x09 (9). File system directory that contains Send To menu items. A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\SendTo.
        'ssfBITBUCKET    0x0a (10). Virtual folder that contains the objects in the user's Recycle Bin.
        'ssfSTARTMENU    0x0b (11). File system directory that contains Start menu items. A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\Start Menu.
        'ssfDESKTOPDIRECTORY 0x10 (16). File system directory used to physically store the file objects that are displayed on the desktop. It is not to be confused with the desktop folder itself, which is a virtual folder. A typical path is C:\Documents and Settings\username\Desktop.
        'ssfDRIVES   0x11 (17). My Computer—the virtual folder that contains everything on the local computer: storage devices, printers, and Control Panel. This folder can also contain mapped network drives.
        'ssfNETWORK  0x12 (18). Network Neighborhood—the virtual folder that represents the root of the network namespace hierarchy.
        'ssfNETHOOD  0x13 (19). A file system folder that contains any link objects in the My Network Places virtual folder. It is not the same as ssfNETWORK, which represents the network namespace root. A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\Network Shortcuts.
        'ssfFONTS    0x14 (20). Virtual folder that contains installed fonts. A typical path is C:\Windows\Fonts.
        'ssfTEMPLATES    0x15 (21). File system directory that serves as a common repository for document templates.
        'ssfCOMMONSTARTMENU  0x16 (22). File system directory that contains the programs and folders that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu. Valid only for Windows NT systems.
        'ssfCOMMONPROGRAMS   0x17 (23). File system directory that contains the directories for the common program groups that appear on the Start menu for all users. A typical path is C:\Documents and Settings\All Users\Start Menu\Programs. Valid only for Windows NT systems.
        'ssfCOMMONSTARTUP    0x18 (24). File system directory that contains the programs that appear in the Startup folder for all users. A typical path is C:\Documents and Settings\All Users\Microsoft\Windows\Start Menu\Programs\StartUp. Valid only for Windows NT systems.
        'ssfCOMMONDESKTOPDIR 0x19 (25). File system directory that contains files and folders that appear on the desktop for all users. A typical path is C:\Documents and Settings\All Users\Desktop. Valid only for Windows NT systems.
        'ssfAPPDATA  0x1a (26). Version 4.71. File system directory that serves as a common repository for application-specific data. A typical path is C:\Documents and Settings\username\Application Data.
        'ssfPRINTHOOD    0x1b (27). File system directory that contains any link objects in the Printers virtual folder. A typical path is C:\Users\username\AppData\Roaming\Microsoft\Windows\Printer Shortcuts.
        'ssfLOCALAPPDATA 0x1c (28). Version 5.0. File system directory that serves as a data repository for local (non-roaming) applications. A typical path is C:\Users\username\AppData\Local.
        'ssfALTSTARTUP   0x1d (29). File system directory that corresponds to the user's non-localized Startup program group.
        'ssfCOMMONALTSTARTUP 0x1e (30). File system directory that corresponds to the non-localized Startup program group for all users. Valid only for Windows NT systems.
        'ssfCOMMONFAVORITES  0x1f (31). File system directory that serves as a common repository for the favorite URLs shared by all users. Valid only for Windows NT systems.
        'ssfINTERNETCACHE    0x20 (32). File system directory that serves as a common repository for temporary Internet files. A typical path is C:\Users\username\AppData\Local\Microsoft\Windows\Temporary Internet Files.
        'ssfCOOKIES  0x21 (33). File system directory that serves as a common repository for Internet cookies. A typical path is C:\Documents and Settings\username\Application Data\Microsoft\Windows\Cookies.
        'ssfHISTORY  0x22 (34). File system directory that serves as a common repository for Internet history items.
        'ssfCOMMONAPPDATA    0x23 (35). Version 5.0. Application data for all users. A typical path is C:\Documents and Settings\All Users\Application Data.
        'ssfWINDOWS  0x24 (36). Version 5.0. Windows directory. This corresponds to the %windir% or %SystemRoot% environment variables. A typical path is C:\Windows.
        'ssfSYSTEM   0x25 (37). Version 5.0. The System folder. A typical path is C:\Windows\System32.
        'ssfPROGRAMFILES 0x26 (38). Version 5.0. Program Files folder. A typical path is C:\Program Files.
        'ssfMYPICTURES   0x27 (39). My Pictures folder. A typical path is C:\Users\username\Pictures.
        'ssfPROFILE  0x28 (40). Version 5.0. User's profile folder.
        'ssfSYSTEMx86    0x29 (41). Version 5.0. System folder. A typical path is C:\Windows\System32, or C:\Windows\Syswow32 on a 64-bit computer.
        'ssfPROGRAMFILESx86  0x30 (48). Version 6.0. Program Files folder. A typical path is C:\Program Files, or C:\Program Files (X86) on a 64-bit computer.
    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 ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", &H1, 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


Public Function DrvGetFreeSpace(drvLetter As String) As Variant
    On Error GoTo ErrHandler
    Dim drv As String: drv = Trim(drvLetter)
    If Len(drv) < 1 Then Err.Raise -10, , "Drive letter is NULL."
'    Dim rng2 As Range: Set rng2 = rng1.Offset(rng1.Parent.Rows.Count - rng1.Row).End(xlUp).Offset(1)
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject").GetDrive(drv)
    With fso
        DrvGetFreeSpace = .FreeSpace
    End With
    
exitPoint:
    On Error Resume Next
'    Set rng1 = Nothing
'    Set rng2 = Nothing
    Set fso = Nothing
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case 68
'            drv = "Drive " & drv & " not found."
            DrvGetFreeSpace = Null
        Case Else
            DrvGetFreeSpace = "#ERROR#" '& Err.Number & vbCrLf & Err.Description
    End Select
    Debug.Print drvLetter, Err.Number, Err.Description
    
    Resume exitPoint
End Function


Public Function DrvGetOccupiedSpace(drvLetter As String) As Variant
    On Error GoTo ErrHandler
    Dim drv As String: drv = Trim(drvLetter)
    If Len(drv) < 1 Then Err.Raise -10, , "Drive letter is NULL."
'    Dim rng2 As Range: Set rng2 = rng1.Offset(rng1.Parent.Rows.Count - rng1.Row).End(xlUp).Offset(1)
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject").GetDrive(drv)
    With fso
        DrvGetOccupiedSpace = .TotalSize - .FreeSpace
    End With
    
exitPoint:
    On Error Resume Next
'    Set rng1 = Nothing
'    Set rng2 = Nothing
    Set fso = Nothing
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case 68
'            drv = "Drive " & drv & " not found."
            DrvGetOccupiedSpace = Null
        Case Else
            DrvGetOccupiedSpace = "#ERROR#" '& Err.Number & vbCrLf & Err.Description
    End Select
    Debug.Print drvLetter, Err.Number, Err.Description
    
    Resume exitPoint
End Function


Public Function FldGetFolderSize(fldPath As String) As Variant
    On Error GoTo ErrHandler
    fldPath = Trim(fldPath)
    If Len(fldPath) <= 3 Then Err.Raise -10, , "Incorrect folder"
'    Dim rng2 As Range: Set rng2 = rng1.Offset(rng1.Parent.Rows.Count - rng1.Row).End(xlUp).Offset(1)
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject").getfolder(fldPath)
        
        FldGetFolderSize = fso.Size
    
exitPoint:
    On Error Resume Next
'    Set rng1 = Nothing
'    Set rng2 = Nothing
    Set fso = Nothing
    
    Exit Function
    
ErrHandler:
    Select Case Err.Number
        Case 70
'            Permission denied - when drive is elected for example - drv = "Drive " & drv & " not found."
            FldGetFolderSize = Null
        Case Else
            FldGetFolderSize = "#ERROR#" '& Err.Number & vbCrLf & Err.Description
    End Select
    Debug.Print fldPath, Err.Number, Err.Description
    
    Resume exitPoint
End Function


Sub checkSubfolders42(strDirectory As String, curLevel As Long, Optional SubDepthLimit As Integer = -1, Optional FolderSize As Boolean = False)
    If SubDepthLimit > 0 Then _
        If curLevel > SubDepthLimit Then Exit Sub
    ''' if SubDepthLimit = 0 - check NO subFolders
    ''' if SubDepthLimit < 0 - check ALL subFolders = NO Limits
    On Error Resume Next
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    Dim i As Integer, str1  As String, j As Long
    
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Get the folder object
    Set objFolder = objFSO.getfolder(strDirectory)
    If objFolder.SubFolders.Count > 0 Then
        'loops through each folder in the directory and prints their names and path
        For Each objSubFolder In objFolder.SubFolders
            With objSubFolder
                '''Folder Properties:
                '''Attributes, DateCreated, DateLastAccessed, DateLastModified,Drive,
                '''Files, IsRootFolder, Name, ParentFolder, Path,
                '''ShortName, ShortPath, Size, SubFolders, Type
                '''Folder Methods: .Copy , .CreateTextFile, .Delete, .Move
                '''FoldersCollection Properties: Count , Item
                '''FoldersCollection Methods: Add
                If FolderSize Then
                    cRng.Resize(1, 12) = _
                        Array("Folder", .Name, Null, .Type, .Size, _
                            .Path, .ParentFolder, curLevel, .Attributes, _
                            .DateCreated, .DateLastModified, .DateLastAccessed)
                Else
                    cRng.Resize(1, 12) = _
                        Array("Folder", .Name, Null, .Type, Null, _
                            .Path, .ParentFolder, curLevel, .Attributes, _
                            .DateCreated, .DateLastModified, .DateLastAccessed)
                End If
            End With
            Set cRng = cRng.Offset(1)
                
'RECURSION: Routine calls itself to drill down and check the contents before moving to next one
            checkSubfolders42 objSubFolder.Path, (curLevel + 1)
        Next objSubFolder
        
    End If
    
    'loops through each file in the directory and prints their names and path
    For Each objFile In objFolder.Files
        With objFile
            '''File Properties:
            '''Attributes, DateCreated, DateLastAccessed, DateLastModified,Drive,
            '''Name, ParentFolder, Path, ShortName, ShortPath, Size, Type
            '''File Methods: .Copy , .Delete, .Move, .OpenAsTextStream
            cRng.Resize(1, 12) = _
                Array("File", .Name, objFSO.GetExtensionName(.Path), .Type, .Size, _
                    .Path, .ParentFolder, curLevel, .Attributes, _
                    .DateCreated, .DateLastModified, .DateLastAccessed)
        End With
        Set cRng = cRng.Offset(1)
    Next objFile
exitPoint:
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objSubFolder = Nothing
    Set objFile = Nothing
End Sub
 

superfb

Board Regular
Joined
Oct 5, 2011
Messages
121
That's great. Thank you for the reply.

I'll have a look at it.

The link to the question you have answered doesn't work...
 

Watch MrExcel Video

Forum statistics

Threads
1,130,112
Messages
5,640,173
Members
417,129
Latest member
geekzilla

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top