VBA Create Object Shell Application Problem

[drluke]

I have the code shown below that someone suggested to me, but I need to change it so that a specific directory is given as starting point for users to then browse for folders to be placed in a user form listbox.
I have no idea what to change to make this happen. Any advise would be appreciated.
The starting point will always be: T:\\Finance\SohoMaccs\2018maccs\Monthly Reports\

Private Sub UserForm_Initialize()
    Dim oFolder As Object, oSubFolder As Object
    Dim sFoldersList As String
    
    Const SF_DOCUMENTS As Long = 5


    sFolder = CreateObject("Shell.Application").Namespace(CVar(SF_DOCUMENTS)).Self.Path


    With CreateObject("Scripting.FileSystemObject")
        
        Set oFolder = .GetFolder(sFolder)
        
        On Error GoTo NextSubFolder '   Error 70 = Permission Denied
        If oFolder.Subfolders.Count > 0 Then
            For Each oSubFolder In oFolder.Subfolders
                sFoldersList = sFoldersList & oSubFolder.Path & ";"
NextSubFolder:
            Next
        End If
    End With


    sFoldersList = Left(sFoldersList, Len(sFoldersList) - 1)


    Me.lbFolder.List = Split(sFoldersList, ";")


    Me.Frame2.Visible = False
    Me.Frame3.Visible = False




End Sub

 

[Trebor76]

Hi drluke,

Try this from code I've adapted from abousetta's thread number 5 from here which I was also a part of:

Option Explicit
Private Sub UserForm_Initialize()

    ListFolders "T:\Finance\SohoMaccs\2018maccs\Monthly Reports\", True '<< Change to your needs. True will include subfolders, False will only return the initial path.

End Sub
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    
    Dim objFSO As Object
    Dim objSourceFolder As Object
    Dim objSubFolder As Object
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objSourceFolder = objFSO.GetFolder(SourceFolderName)

    If IncludeSubfolders = True Then
        For Each objSubFolder In objSourceFolder.SubFolders
            ListFolders objSubFolder.Path, True
            Me.lbFolder.AddItem objSubFolder.Path
        Next objSubFolder
    Else
        Me.lbFolder.AddItem objSourceFolder
    End If
    
    Set objSubFolder = Nothing
    Set objSourceFolder = Nothing
    Set objFSO = Nothing
    
End Sub

Regards,

Robert