One of the useful uses of the Windows API, back in the old days of 32 bits programming, was to use the shell’s standard dialogs for browsing for a folder or picking a file. VB/VBA didn’t have a way to do that, whereas today, modern VB, I mean VBA7 of course (today’s “Visual Basic” denomination being attributed to the VB.NET treacherous brother), has beautiful means to do that; just install some megabytes of Office and there you go.
So there is the 32 bits code I use for browsing for a folder:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Private Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Private Declare Function SHBrowseForFolder Lib "shell32" _ (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" _ (ByVal pidList As Long, _ ByVal lpBuffer As String) As Long Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _ (ByVal lpString1 As String, ByVal lpString2 As String) As Long |
Now, I couldn’t find a way to make this work in 64 bits, and frankly, Internet has a lot of bugged code for you to try to. Many claim to have something working, I couldn’t find the correct declarations and calls to avoid GPFing. The crashes occur when invoking SHGetPathFromIDList.
Here’s how to do it in modern VBA (got it on developpez.net), and in classic VB5/VB6; note that we don’t need a port anymore as there’s is no 64 bits VB/VBA, thanks Microsoft, we always knew you wouldn’t let us down:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
#If Win64 Or MSACCESS Or MSEXCEL Or MSWORD Then 'You define those in your project properties Public Function BrowseForFolder(ByVal hwnd As LongPtr, ByVal szTitle As String) As String Dim lpIDList As LongPtr With Application.FileDialog(msoFileDialogFolderPicker) .Title = szTitle .AllowMultiSelect = False If .Show = -1 Then BrowseForFolder = .SelectedItems(1) End If End With End Function #Else #If Win64 Then Public Function BrowseForFolder(ByVal hwnd As Long, ByVal szTitle As String) As String MsgBox "BrowseForFolder : not implemented", vbCritical 'Who cares, we have no 64 bits VB5/6 End Function #Else Public Function BrowseForFolder(ByVal hwnd As Long, ByVal szTitle As String) As String Dim lpIDList As Long Dim sBuffer As String Dim tBrowseInfo As BrowseInfo With tBrowseInfo .hWndOwner = hwnd .lpszTitle = szTitle .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN End With lpIDList = SHBrowseForFolder(tBrowseInfo) If (lpIDList) Then sBuffer = String$(MAX_PATH * 4, Chr$(0)) SHGetPathFromIDList lpIDList, sBuffer sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) BrowseForFolder = sBuffer End If End Function #End If #End If |
So, SHxxx or Shell functions are indeed hell-ish! As another example, it took me quite some time to port to 64 bits the damned SHGetSpecialFolderLocation function.
Again, hard to find any truly working code on the net.
So, let’s go for mine if you don’t mind. Here’s how I declare it:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
#If Win64 Then Private Type SHITEMID cb As LongPtr abID As Byte End Type Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal pidl As Any, ByVal pszPath As String) As Boolean Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _ (ByVal hWndOwner As LongPtr, ByVal nFolder As Long, pidl As ITEMIDLIST) As LongPtr #Else Private Type SHITEMID cb As Long abID As Byte End Type Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long #End If Private Type ITEMIDLIST mkid As SHITEMID End Type Public Enum esfSpecialFolder CSIDL_DESKTOP = &H0 CSIDL_PROGRAMS = &H2 CSIDL_CONTROLS = &H3 CSIDL_PRINTERS = &H4 CSIDL_PERSONAL = &H5 CSIDL_FAVORITES = &H6 CSIDL_STARTUP = &H7 CSIDL_RECENT = &H8 CSIDL_SENDTO = &H9 CSIDL_BITBUCKET = &HA CSIDL_STARTMENU = &HB CSIDL_DESKTOPDIRECTORY = &H10 CSIDL_DRIVES = &H11 CSIDL_NETWORK = &H12 CSIDL_NETHOOD = &H13 CSIDL_FONTS = &H14 CSIDL_TEMPLATES = &H15 CSIDL_COMMON_STARTMENU = &H16 CSIDL_COMMON_PROGRAMS = &H17 CSIDL_COMMON_STARTUP = &H18 CSIDL_COMMON_DESKTOPDIRECTORY = &H19 CSIDL_APPDATA = &H1A CSIDL_PRINTHOOD = &H1B End Enum |
And there’s how I make it work without crashing:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
Public Function GetSpecialFolder(eSpecialFolderID As esfSpecialFolder) As String #If Win64 Then Dim lRet As LongPtr Dim lTrans As LongPtr #Else Dim lRet As Long Dim lTrans As Long #End If Dim spath As String Dim TITEMIDLIST As ITEMIDLIST Const klMaxLength As Long = 1024& 'GetDesktopWindow() is a trivial declare, add it to your module declares lRet = SHGetSpecialFolderLocation(GetDesktopWindow(), _ eSpecialFolderID, _ TITEMIDLIST) If lRet = 0 Then spath = String$(klMaxLength, Chr$(0)) lTrans = TITEMIDLIST.mkid.cb lRet = SHGetPathFromIDList(ByVal lTrans, spath) If lRet <> 0 Then GetSpecialFolder = Left$(spath, InStr(spath, Chr$(0)) - 1) & "" End If End If End Function |
Hey, hope I spared you some head banging guys !
Cheers 😉
Hi,
I want to select the folder from a dialog. How do i do that? I dont need specialfolders.
In VB5/8 you can call the BrowseForFolder() function, like in this snippet:
Dim SelectedFolderName as String
SelectedFolderName = BrowseForFolder(0&, “Pick a folder”)
Debug.Print “The selected folder is named: “; SelectedFolderName
But today, if you’re on VBA (Access, Excel, Word, etc..), you can now use the built-in Application FileDialog object, as in this example where I wrap it in a SelectDir function:
Public Function SelectDir(ByVal psTitle As String) As String
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = psTitle
If .Show() Then
SelectDir = .SelectedItems(1)
End If
End With
End Function
And then use it like that:
Dim SelectedFolderName as String
SelectedFolderName = SelectDir(0&, “Pick a folder”)
Debug.Print “The selected folder is named: “; SelectedFolderName
Cheers
Nice work! Thanks!
WOW !!
TITEMIDLIST = ITEMIDLIST, the “T” was intentionally added when I was messing with all this stuff, I didn’t care to take it off after, but to be consistent with the API definitions it should be. You’re right (as is jpk-ads.com, which is by the way also a great source, thanks), the return value should also be declared as boolean for the sake of consistency with the API. I do not remember why I got from LongPtr to Any for the PIDL. They may probably end up to be equivalent in that case. Anyway, as both versions make sense I’m keeping the version with which I tested for that one. I’m updating the post. Happy coding 😉
Awesome, your code DID save me lots of time. And, I liked how you also made the function for both 32- and 64-bit by using Enum. The only thing I changed was “TITEMIDLIST” to “ITEMIDLIST.” Was it an intentional misspelling? I also used the declares listed at http://www.jkp-ads.com/articles/apideclarations.asp. The SHGetPathFromIDList is declared as a boolean, with the pidl handle set to longptr and long.