List Folders & Subfolders From Directory

Sub Ck()


Dim strStartPath As String
    
    strStartPath = "C:\" 'ENTER YOUR START FOLDER HERE
    ListFolder strStartPath


End Sub
Sub ListFolder(sFolderPath As String)


Dim FS As New FileSystemObject
Dim FSfolder As Folder
Dim subfolder As Folder
Dim i As Integer


    Set FSfolder = FS.GetFolder(sFolderPath)
    
    For Each subfolder In FSfolder.SubFolders
        DoEvents
        i = i + 1
'added this line
        Cells(i, 1) = subfolder
'commented out this one
        'Debug.Print subfolder
    Next subfolder
    
    Set FSfolder = Nothing


'optional, I suppose    
    MsgBox "Total sub folders in " & sFolderPath & " : " & i


End Sub

Option Explicit


Sub TestListFolders()
    
    Application.ScreenUpdating = False
    
    'create a new workbook for the folder list


'commented out by dr
    'Workbooks.Add
    
'line added by dr to clear old data
    Cells.Delete
    
    ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    
    Range("A3").Formula = "Folder Path:"
    Range("B3").Formula = "Folder Name:"
    Range("C3").Formula = "Size:"
    Range("D3").Formula = "Subfolders:"
    Range("E3").Formula = "Files:"
    Range("F3").Formula = "Short Name:"
    Range("G3").Formula = "Short Path:"
    Range("A3:G3").Font.Bold = True
    
    'ENTER START FOLDER HERE
    ' and include subfolders (true/false)
    ListFolders "C:\", True
    
    Application.ScreenUpdating = True
    
End Sub


Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
' example: ListFolders "C:\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
    
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    
'line added by dr for repeated "Permission Denied" errors
    
    On Error Resume Next
    
    ' display folder properties
    r = Range("A65536").End(xlUp).Row + 1
    Cells(r, 1).Formula = SourceFolder.Path
    Cells(r, 2).Formula = SourceFolder.Name
    Cells(r, 3).Formula = SourceFolder.Size
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    Cells(r, 5).Formula = SourceFolder.Files.Count
    Cells(r, 6).Formula = SourceFolder.ShortName
    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
    
    Columns("A:G").AutoFit
    
    Set SourceFolder = Nothing
    Set FSO = Nothing
    
'commented out by dr
    'ActiveWorkbook.Saved = True


End Sub

Const BIF_RETURNONLYFSDIRS As Long = &H1        ''' For finding a folder to start document searching
Const BIF_DONTGOBELOWDOMAIN As Long = &H2       ''' Does not include network folders below the domain level in the tree view control
Const BIF_RETURNFSANCESTORS As Long = &H8       ''' Returns only file system ancestors.
Const BIF_BROWSEFORCOMPUTER As Long = &H1000    ''' Returns only computers.
Const BIF_BROWSEFORPRINTER As Long = &H2000     ''' Returns only printers.
Const BIF_BROWSEINCLUDEFILES As Long = &H4000   ''' Returns everything.


Const MAX_PATH As Long = 260


Type BROWSEINFO
    hOwner     As Long
    pidlRoot   As Long
    pszDisplayName As String
    lpszINSTRUCTIONS As String
    ulFlags    As Long
    lpfn       As Long
    lParam     As Long
    iImage     As Long
End Type


Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long




Function BrowseFolder() As String


    Const szINSTRUCTIONS As String = "Choose the folder to use for this operation." & vbNullChar


    Dim uBrowseInfo As BROWSEINFO
    Dim szBuffer As String
    Dim lID    As Long
    Dim lRet   As Long


    With uBrowseInfo
        .hOwner = 0
        .pidlRoot = 0
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = szINSTRUCTIONS
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfn = 0
    End With


    szBuffer = String$(MAX_PATH, vbNullChar)


    ''' Show the browse dialog.
    lID = SHBrowseForFolderA(uBrowseInfo)


    If lID Then
        ''' Retrieve the path string.
        lRet = SHGetPathFromIDListA(lID, szBuffer)
        If lRet Then BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
    End If


End Function

Option Explicit


Sub CreateList()
    Application.ScreenUpdating = False
    Workbooks.Add    ' create a new workbook for the folder list
    ' add headers
    With Cells(1, 1)
        .Value = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Cells(3, 1).Value = "Folder Path:"
    Cells(3, 2).Value = "Folder Name:"
    Cells(3, 3).Value = "Size:"
    Cells(3, 4).Value = "Subfolders:"
    Cells(3, 5).Value = "Files:"
    Cells(3, 6).Value = "Short Name:"
    Cells(3, 7).Value = "Short Path:"
    Range("A3:G3").Font.Bold = True
    ListFolders BrowseFolder, True
    Application.ScreenUpdating = True
End Sub


Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    ' lists information about the folders in SourceFolder
    Dim FSO    As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r      As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    ' display folder properties
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(r, 1).Value = SourceFolder.Path
    Cells(r, 2).Value = SourceFolder.Name
    Cells(r, 3).Value = SourceFolder.Size
    Cells(r, 4).Value = SourceFolder.SubFolders.Count
    Cells(r, 5).Value = SourceFolder.Files.Count
    Cells(r, 6).Value = SourceFolder.ShortName
    Cells(r, 7).Value = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
    Columns("A:G").AutoFit
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True


End Sub