Browse For Folder Explorer Style

[JJGey]

I have a VBA code to open the Windows Explorer style dialogue and select a Folder. This works fine in Excel but doesn't work other VBA application which doesn't support Microsoft Office File Dialogue control
Is it possible modify and run this code
Thanks!

Code: Select all

Const MAX_PATH As Long = 260
Const dhcErrorExtendedError = 1208&
Const dhcNoError = 0&

'specify root dir for browse for folder by constants
'you can also specify values by constants for searhcable folders and options.
Const dhcCSIdlDesktop = &H0
Const dhcCSIdlPrograms = &H2
Const dhcCSIdlControlPanel = &H3
Const dhcCSIdlInstalledPrinters = &H4
Const dhcCSIdlPersonal = &H5
Const dhcCSIdlFavorites = &H6
Const dhcCSIdlStartupPmGroup = &H7
Const dhcCSIdlRecentDocDir = &H8
Const dhcCSIdlSendToItemsDir = &H9
Const dhcCSIdlRecycleBin = &HA
Const dhcCSIdlStartMenu = &HB
Const dhcCSIdlDesktopDirectory = &H10
Const dhcCSIdlMyComputer = &H11
Const dhcCSIdlNetworkNeighborhood = &H12
Const dhcCSIdlNetHoodFileSystemDir = &H13
Const dhcCSIdlFonts = &H14
Const dhcCSIdlTemplates = &H15

'constants for limiting choices for BrowseForFolder Dialog

Const dhcBifReturnAll = &H0
Const dhcBifReturnOnlyFileSystemDirs = &H1
Const dhcBifDontGoBelowDomain = &H2
Const dhcBifIncludeStatusText = &H4
Const dhcBifSystemAncestors = &H8
Const dhcBifBrowseForComputer = &H1000
Const dhcBifBrowseForPrinter = &H2000


#If VBA7 Then
    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type


#Else
    Private 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
 
#End If

Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef pidl As Long) As Long

Private Function BrowseForFolder(ByVal lngCSIDL As Long, _
    ByVal lngBiFlags As Long, _
    strFolder As String, _
    Optional ByVal hWnd As Long = 0, _
Optional pszTitle As String = "Select Folder") As Long

     Dim usrBrws As BROWSEINFO
     Dim lngReturn As Long
     Dim lngIDL As Long
     If SHGetSpecialFolderLocation(hWnd, lngCSIDL, lngIDL) = 0 Then
        'set up the browse structure here
        With usrBrws
            .hwndOwner = hWnd
            .pidlRoot = lngIDL
            .pszDisplayName = String$(MAX_PATH, vbNullChar)
            .pszTitle = pszTitle
            .ulFlags = lngBiFlags
        End With
        'open the dialog
        lngIDL = SHBrowseForFolder(usrBrws)
        'if successful
        If lngIDL Then strFolder = String$(MAX_PATH, vbNullChar)
            'resolve the long value form the lngIDL to a real path
            If SHGetPathFromIDList(lngIDL, strFolder) Then
                strFolder = Left(strFolder, InStr(1, strFolder, vbNullChar))
            lngReturn = dhcNoError 'to show there is no error.
            Else
                'nothing real is available.
                'return a virtual selection
                strFolder = Left(usrBrws.pszDisplayName, InStr(1, usrBrws.pszDisplayName, vbNullChar))
            lngReturn = dhcNoError 'to show there is no error.
            End If
     Else
        lngReturn = dhcErrorExtendedError 'something went wrong
     End If
     BrowseForFolder = lngReturn
End Function

[snb]

What is your budget ?
Which other 'VBA-applications' ?

[ChrisGreaves]

Hi JJGey,
I have attached a module of code from a Word2003/VBA library.
I use this code to open dialogue boxes for the user to select files, folder.
Cheers
Chris

[JJGey]

What is your budget ?

I don't understand what's this mean..

Which other 'VBA-applications' ?

It's a CAD application for drawings

[HansV]

Your code is incomplete. Does Browsing folder for selecting folder using VBA in Microsoft Excel work?

Or, much simpler:

Code: Select all

Sub FolderDialog()
    Dim strFolder As String
    On Error Resume Next
    strFolder = CreateObject("Shell.Application").BrowseForFolder(&H0, "Select a folder", &H30).Self.Path
    If strFolder = "" Then
        MsgBox "You didn't select a folder!"
    Else
        MsgBox "You selected " & strFolder
        ' Do something with the folder
    End If
End Sub

[JJGey]

Here is the execution part of the code
This works perfect in my Excel but gives error in my other VBA application "Set fd = Application.FileDialog(msoFileDialogFolderPicker)"

Code: Select all

Sub Test()
     
     Dim fd As Office.FileDialog
     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
     Dim vrtSelectedItem As Variant
     With fd
        If .Show = -1 Then
            For Each vrtSelectedItem In .SelectedItems
                MsgBox "The path is: " & vrtSelectedItem
                strPath = vrtSelectedItem
            Next vrtSelectedItem
        Else
            MsgBox "Please select a folder"
        End If
     End With

End Sub

[HansV]

FileDialog is specific to Microsoft Office, it is not available in other applications that have VBA. Have you tried the code from my previous reply?

[JJGey]

FileDialog is specific to Microsoft Office, it is not available in other applications that have VBA. Have you tried the code from my previous reply?

Thanks HansV,
Your previous code works
I was trying to get bit more fancy to reduce the mouse clicks
Something like this with double pane

[HansV]

Does this work from your CAD application?

Code: Select all

Sub FolderDialog2()
    Dim xlApp As Object
    Dim strFolder As String
    Set xlApp = CreateObject("Excel.Application")
    With xlApp.FileDialog(4)
        If .Show Then
            strFolder = .SelectedItems(1)
            ' Do something with the folder
            '...
        End If
    End With
    xlApp.Quit
End Sub

[snb]

Try

Code: Select all

Sub M_snb()
    CreateObject("Shell.Application").Explore "C:\"
End Sub

or

Code: Select all

Sub M_snb()
    Shell "explorer.exe C:\", 1
End Sub

[HansV]

Hi snb,

That will indeed display an Explorer window, but how does one retrieve the folder selected by the user in the macro?

[JJGey]

Does this work from your CAD application?

Code: Select all

Sub FolderDialog2()
    Dim xlApp As Object
    Dim strFolder As String
    Set xlApp = CreateObject("Excel.Application")
    With xlApp.FileDialog(4)
        If .Show Then
            strFolder = .SelectedItems(1)
            ' Do something with the folder
            '...
        End If
    End With
    xlApp.Quit
End Sub

This works..
Thanks a lot HansV
Takes a bit to load the dialogue, that's OK, I can live with that.

[HansV]

Since FileDialog is only available in Office, the code uses an Office application (Excel in this example) to display the dialog. Starting that application takes a bit of time.
If you need to display the dialog frequently during a session, it would be more efficient to start Excel once and keep it open. Let me know if you want that.

[JJGey]

Since FileDialog is only available in Office, the code uses an Office application (Excel in this example) to display the dialog. Starting that application takes a bit of time.
If you need to display the dialog frequently during a session, it would be more efficient to start Excel once and keep it open. Let me know if you want that.

Hanv,
Thanks for your help.
Please give me the code to work with Excel. I can keep Excel open whenever I use the CAD application

[HansV]

Place the following code at the top of a standard module (below Option Explicit if you have that):

Code: Select all

Public xlApp As Object

Function GetXL() As Object
    On Error Resume Next
    If xlApp Is Nothing Then
        On Error Resume Next
        Set xlApp = GetObject(Class:="Excel.Application")
        On Error GoTo 0
        If xlApp Is Nothing Then
            Set xlApp = CreateObject(Class:="Excel.Application")
        End If
    End If
    Set GetXL = xlApp
End Function

Change the FolderDialog2 macro as follows:

Code: Select all

Sub FolderDialog2()
    Dim strFolder As String
    With GetXL.FileDialog(4)
        If .Show Then
            strFolder = .SelectedItems(1)
            ' Do something with the folder
            '...
        End If
    End With
End Sub

[JJGey]

Thanks again Hans,
This is works perfect and I can add more options