VBA to list folder names and Size

[Biz]

Dear All,

I am trying to create VBA to list folders and size. Can someone pls help me?

Kind Regards,

Bhavik

 

[dk]

Hi

This is some code from my own library of useful tools. Copy and paste the code and then run the GetFolderList procedure.

Option Explicit

Private lngRow As Long

'This is the string that will be used to indent the folder names
Private Const IndentingChar As String = "---"

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


'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
        As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
        Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Sub GetFolderList()
    Dim strStartFolder As String
    Dim FSORootFolder As Object
    Dim FSORootSubFolders As Object
    Dim FSOObj As Object
    Dim sht As Worksheet
    
    On Error GoTo ErrHandler

    'This is the root folder
    strStartFolder = GetDirectory("Please choose folder to start in")

    If Len(strStartFolder) = 0 Then Exit Sub

    'Increase the execution speed of the macro
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set sht = Workbooks.Add(xlWBATWorksheet).Sheets(1)
    sht.Name = "Folder List"
    
    

    Set FSOObj = CreateObject("Scripting.FilesystemObject")
    Set FSORootFolder = FSOObj.GetFolder(strStartFolder)

    'lngRow represents which row we're going to write to on the active sheet
    lngRow = 1

    sht.Cells(lngRow, 1) = "Folder Path"
    sht.Cells(lngRow, 2) = "Folder Size (MB)"
    lngRow = lngRow + 1


    sht.Cells(lngRow, 1) = FSORootFolder.path
    sht.Cells(lngRow, 2) = Round(FSORootFolder.Size / 1024 / 1024, 0)
    lngRow = lngRow + 1

    'Loop through each of the folders that lie immediately beneath the subfolder
    For Each FSORootSubFolders In FSORootFolder.SubFolders

        ListSubFolders FSORootSubFolders, sht

    Next FSORootSubFolders

    sht.UsedRange.Font.Name = "Courier"
    sht.UsedRange.Columns.AutoFit


ErrHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual

    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "Something has gone wrong :-("
    End If

End Sub



Private Function GetParentFolderCount(PathSpec As String) As Long
    Dim lngCharCounter As Long, lngRetVal As Long

    For lngCharCounter = 1 To Len(PathSpec)
        If Mid$(PathSpec, lngCharCounter, 1) = Application.PathSeparator Then _
                lngRetVal = lngRetVal + 1
    Next lngCharCounter

    GetParentFolderCount = lngRetVal
End Function

Private Sub ListSubFolders(ParentFolder As Object, sht As Worksheet)
    Dim FSOSubfolder As Object


    'Does the folder that we're working with have any folders beneath it?
    'If so, we'll call this procedure again for each of those folders
    'beneath the parent folder.
    If ParentFolder.SubFolders.Count > 0 Then
        sht.Cells(lngRow, 1) = Application.WorksheetFunction.Rept(IndentingChar, _
                GetParentFolderCount(ParentFolder.path) - 1) & ParentFolder.path
        sht.Cells(lngRow, 2) = Round(ParentFolder.Size / 1024 / 1024, 0)
        lngRow = lngRow + 1

        For Each FSOSubfolder In ParentFolder.SubFolders
            ListSubFolders FSOSubfolder, sht
        Next FSOSubfolder

    Else

        'If ParentFolder has no folders beneath it then just
        'output the folder's name to the worksheet
        sht.Cells(lngRow, 1) = Application.WorksheetFunction.Rept(IndentingChar, _
                GetParentFolderCount(ParentFolder.path) - 1) & ParentFolder.path
        sht.Cells(lngRow, 2) = Round(ParentFolder.Size / 1024 / 1024, 0)
            
        
        lngRow = lngRow + 1

    End If

End Sub


Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

    '   Root folder = Desktop
    bInfo.pidlRoot = 0&

    '   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If

    '   Type of directory to return
    bInfo.ulFlags = &H1

    '   Display the dialog
    x = SHBrowseForFolder(bInfo)

    '   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

HTH
DK

 

[Biz]

Hi,

Got an error message

Automation error Library not registered.

Biz

 

[dk]

Is it a compile error, or a run-time error? If you click Debug, Compile do you get any error message. If the error occurs when you run the macro, what line does it happen on?

 

[Biz]

It seems
Set FSOObj = CreateObject("Scripting.FilesystemObject")

Does not work?
Do I need to add additional references.

Biz

 

[dk]

That's odd - I've not seen that error before. What version of Windows and Office are you using? You might want to see if this helps you fix the problem: http://support.microsoft.com/defaul...port/kb/articles/Q274/0/38.ASP&NoWebContent=1


HTH
DK

 

[Biz]

Hi DK ,

It works. I re-registering scrrun.dll.
Windows start, Run, enter the following and hit enter
regsvr32 scrrun.dll.

Sorry for inconvenience.

Biz

 

[Einherjer]

Hello.

I have the following VBA code:


Option Explicit

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetpathfromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO

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


Function GetDirectory(Optional Msg) As String

Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

bInfo.pidlRoot = 0&

If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

bInfo.ulFlags = &H1

x = SHBrowseForFolder(bInfo)

path = Space$(512)

r = SHGetPathFromIDList(ByVal x, ByVal path)

If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If

End Function


Sub GetLPFolder()

Dim Msg As String
Dim Userfile As String
Msg = "Please select location of C&E LP Folder."
Userfile = GetDirectory(Msg)

If Userfile = "" Then
MsgBox "Canceled"
Else
MsgBox Userfile
End If

End Sub


The purpose it's to read a path, by clicking a button in a User Form and then add the selected path to a Text Box in the same User Form. The code for the button and the text box are not displayed here. My problem is that I get an error when I run the GetLPFolder procedure. The line were the error occurs is "r = SHGetPathFromIDList(ByVal x, ByVal path)" and the error message is: "Can't find DLL entry point SHGetpathfromIDListA in shell32.dll".

Anybody has any idea why?

Thanks in advance.

 

[dk]

Hi

The problem is with the declaration of the Win32 calls:

You have this:

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetpathfromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

The declaration is case sensitive so you must use this:

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Note the capitalisation for the P and F.

HTH
DK

 

[Einherjer]

Thanks, dk. It works now.