BrowseForFolder API Makes Excel Crash

[ImranBhatti]

Hi,

I am using the bellow API Calls to bring up the windows standard Folder Picker. The Folder Picker DOES appear. However when I select a folder and click its "OK" button, it makes Excel crash.

Can someone please figure this out as to where I am making mistake, because I myself tried to make it 64-bit compatible by using Ptrsafe keyword and changing the pointers data type from Long to Longptr.

Question 2: How can we make it show the files of the folders as well? (it currently shows only folder)

Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As LongPtr
        lpfn As Long
        lParam As LongPtr
        iImage As LongPtr
End Type
'Commonly-used ulFlags constants
'Only return file system directories.
'If the user selects folders that are not
'part of the file system (such as 'My Computer'),
'the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
'Use a newer dialog style, which gives a richer experience
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
'Hide the default 'Make New Folder' button
Private Const BIF_NONEWFOLDERBUTTON As Long = &H200
'Messages sent from dialog to callback function
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
'Messages sent to browser from callback function
Private Const WM_USER = &H400
'Set the selected path
Private Const BFFM_SETSELECTIONA = WM_USER + 102

'Enable/disable the OK button
Private Const BFFM_ENABLEOK = WM_USER + 101
'The maximum allowed path
Private Const MAX_PATH = 260
'Main Browse for directory function
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(ByRef lpBrowseInfo As BROWSEINFO) As Long
'Gets a path from a pidl
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
'Used to set the browse dialog's title
Declare PtrSafe Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
'A versions of SendMessage, to send strings to the browser
Private Declare PtrSafe Function SendMessageString Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As String) As Long
'Variables to hold the initial options,
'set in the callback function
Dim msInitialPath As String
Dim msTitleBarText As String
'The main function to initialize and show the dialog
Function GetDirectory(Optional ByVal sInitDir As String, _
Optional ByVal sTitle As String, _
Optional ByVal sMessage As String, _
Optional ByVal hwndOwner As Long, _
Optional ByVal bAllowCreateFolder As Boolean) _
As String

'A variable to hold the UDT
Dim uInfo As BROWSEINFO
Dim sPath As String
Dim lResult As Long
'Check that the initial directory exists
On Error Resume Next
sPath = Dir(sInitDir & "\*.*", vbNormal + vbDirectory)
If Len(sPath) = 0 Or Err.Number <> 0 Then sInitDir = ""
On Error GoTo 0
'Store the initials setting in module-level variables,
'for use in the callback function
msInitialPath = sInitDir
msTitleBarText = sTitle
'If no owner window given, use the Excel window
'N.B. Uses the ApphWnd function in MWindows
If hwndOwner = 0 Then hwndOwner = ApphWnd
'Initialise the structure to pass to the API function
With uInfo
.hOwner = hwndOwner
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszTitle = sMessage
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE _
+ IIf(bAllowCreateFolder, 0, BIF_NONEWFOLDERBUTTON)
'Pass the address of the callback function in the UDT
'.lpfn = LongToLong(AddressOf BrowseCallBack)
End With
'Display the dialog, returning the ID of the selection
lResult = SHBrowseForFolder(uInfo)
'Get the path string from the ID
GetDirectory = GetPathFromID(lResult)
End Function
'Windows calls this function when the dialog events occur
'imran
Private Function BrowseCallBack(ByVal hwnd As LongPtr, _
ByVal Msg As LongPtr, ByVal lParam As LongPtr, _
ByVal pData As LongPtr) As LongPtr
Dim sPath As String
'This is called by Windows, so don't allow any errors!
On Error Resume Next
Select Case Msg
Case BFFM_INITIALIZED
'Dialog is being initialized,
'so set the initial parameters
'The dialog caption
If msTitleBarText <> "" Then
SetWindowText hwnd, msTitleBarText
End If
'The initial path to display
If msInitialPath <> "" Then
SendMessageString hwnd, BFFM_SETSELECTIONA, 1, _
msInitialPath
End If
Case BFFM_SELCHANGED
'User selected a folder
'lParam contains the pidl of the folder, which can be
'converted to the path using GetPathFromID
'sPath = GetPathFromID(lParam)
'We could put extra checks in here,
'e.g. to check if the folder contains any workbooks,
'and send the BFFM_ENABLEOK message to enable/disable
'the OK button:
'SendMessage hwnd, BFFM_ENABLEOK, 0, True / False
End Select
End Function
'Converts a PIDL to a path string
Private Function GetPathFromID(ByVal lID As Long) As String
Dim lResult As Long
Dim sPath As String * MAX_PATH

lResult = SHGetPathFromIDList(lID, sPath)
If lResult <> 0 Then
GetPathFromID = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
End If
End Function
'VBA doesn 't let us assign the result of AddressOf
'to a variable, but does allow us to pass it to a function.
'This 'do nothing' function works around that problem
Private Function LongToLong(ByVal lAddr As Long) As Long
LongToLong = lAddr
End Function

usage:

Sub BrowseFolder()
Dim fldr As String

fldr = GetDirectory("A path to sub folder", "Browse")
End Sub

This is the line that actually crashed Excel

lResult = SHGetPathFromIDList(lID, sPath)

in GetPathFromID function.


Help would br greatly appreciated.

Best Regards

Imran Bhatti

[Marc L]

Hi !

Q2 : not with this folders only browser !

Why don't you just use the Excel / VBA features ?

[ImranBhatti]

Thanks, Mark! For Answer 2:

I was just after displaying the Folders in hierarchical (i.e.Treeview) but using a built-in dialogue and not creating my own treeview. But not sure why it is crashing Excel application.

[Marc L]

Could be something broken on Windows side …

[Marc L]

As the best seems to use internal Excel / VBA features like the classic FileDialog or even the so easy GetOpenFilename …

Anyway a demonstration to browse folders only :

Sub DemoFolder()
    Dim obj As Object, P$
    Set obj = CreateObject("Shell.Application").BrowseForFolder(0, vbLf & "Sélection :", 1, "")
     If obj Is Nothing Then Beep: Exit Sub Else P = obj.Self.Path & "\": Set obj = Nothing
    MsgBox P
End Sub 

[ImranBhatti]

@sir Marc

Firstly thank you so much for the shortest code for the outcome that I was after. Currently, I wanted to have a tree view of folders and let the user expand and collapse the hierarchy which is achieved via your code.

Secondly, is there a parameter for your code to further show the files of these folders?

Once again thank you so much*1000 (cos you are beyond reputation)

Best Regards
Imran Bhatti

[Marc L]

No as it's for folders only …

But you can use GetOpenFilename or better FileDialog where it seems you can setup the view …