1st module : 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
2nd module :
Option Explicit
Sub CreateList() Application.ScreenUpdating = False Worksheets.Add ' create a new worksheet for the folder list 'Worksheets.Name = SourceFolder.Name ' 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 (Mo):" Cells(3, 4).Value = "Subfolders:" Cells(3, 5).Value = "Files:" Cells(3, 6).Value = "Short Name:" 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(1, 2).Value = SourceFolder.Path Cells(r, 1).Value = SourceFolder.Path Cells(r, 2).Value = SourceFolder.Name Cells(r, 3).Value = SourceFolder.Size / 1000000 Cells(r, 3).NumberFormat = "0.00" Cells(r, 4).Value = SourceFolder.SubFolders.Count Cells(r, 5).Value = SourceFolder.Files.Count Cells(r, 6).Value = SourceFolder.ShortName 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 |