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 😉
Recent Comments