topic Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList in VBA Forum

64 Bit Win API Call - SHGetPathFromDList

Anonymous — Sat, 23 Dec 2017 12:24:41 GMT

Having Issues with getting Browse Folder Windows API Call to work. Am converting older VBA 32 (from Autocad R14 !!!) to Win64.

I have found other posts for this but those solutions are not working.

This is causing a fatal AutoCad Error (Autocad itself bombs)

Thanks in advance for any perspective

#If Win64 Then
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long

Else

...

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

Function Prompt4Path() As String

'promps user for a valid path and add trailing \ if reqd
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim szRootDir As String
Dim tBrowseInfo As BROWSEINFO
Dim retval As String
Dim MAXPATH As Long

MAXPATH = 256

On Error GoTo PromtErr
'set title
szTitle = "Select Directory"
szRootDir = "C:\"

With tBrowseInfo
' .hWndOwner = UserForm2.MultiPage1.HWnd
.lpszTitle = lstrcat(szTitle, "")
.pidlRoot = lstrcat(szRootDir, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With

'display browse tree view
lpIDList = SHBrowseForFolder(tBrowseInfo)

'check return value
If (lpIDList) Then
sBuffer = Space$(MAXPATH)
retval = SHGetPathFromIDList(lpIDList, sBuffer) ' Dies right here - terminal error - AutoCad Dies
If (retval) Then
Prompt4Path$ = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
End If

CoTaskMemFree lpIDList

'add trailing \ if req'd
If Not Right(Prompt4Path$, 1) = "\" Then
Prompt4Path$ = Prompt4Path$ & "\"
End If
Else
Prompt4Path = ""
End If

Exit Function

PromtErr:
Prompt4Path$ = ""
End Function

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Anonymous — Wed, 10 Jun 2020 09:22:37 GMT

You have to convert very carful pointers from long to longPtr. If you forget one you will crash.

Code below will work if you copy into a module:

----------------------------------------------------------------------------------------------------------------

Option Explicit
#If VBA7 Then
Private Type BrowseInfo
    Owner As LongPtr
    RootIdl As LongPtr
    DisplayName As String
    Title As String
    flags As Long
    CallbackAddress As LongPtr
    CallbackParam As LongPtr
    Image As Long
End Type

Private Type SHITEMID
    cb As Long
    abID As Byte
End Type

Private Type ITEMIDLIST
    mkid As SHITEMID
End Type
#Else
Private Type BrowseInfo
    Owner As Long
    RootIdl As Long
    DisplayName As String
    Title As String
    flags As Long
    CallbackAddress As Long
    CallbackParam As Long
    Image As Long
End Type
#End If
Private Const MAX_PATH_Unicode As Long = 519 ' 260 * 2 - 1
Private Const MAX_PATH = MAX_PATH_Unicode 'As Long = 260

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSELECTIONA = WM_USER + 102
Private Const BFFM_SETSELECTION = BFFM_SETSELECTIONA
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only

Private Const BIF_RETURNONLYFSDIRS   As Long = &H1 'only file system directories
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 'no network folders below domain level
Private Const BIF_STATUSTEXT As Long = &H4         'include status area for callback
Private Const BIF_RETURNFSANCESTORS As Long = &H8 'only return file system ancestors
Private Const BIF_EDITBOX As Long = &H10           'add edit box
Private Const BIF_NEWDIALOGSTYLE As Long = &H40    'use the new dialog layout
Private Const BIF_UAHINT As Long = &H100
Private Const BIF_NONEWFOLDERBUTTON As Long = &H200 'hide new folder button
Private Const BIF_NOTRANSLATETARGETS As Long = &H400 'return lnk file
Private Const BIF_USENEWUI As Long = BIF_NEWDIALOGSTYLE Or BIF_EDITBOX
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 'only return computers
Private Const BIF_BROWSEFORPRINTER As Long = &H2000 'only return printers
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 'browse for everything
Private Const BIF_SHAREABLE As Long = &H8000 'sharable resources, requires BIF_USENEWUI
'class ID values
Private Const CSIDL_DESKTOP As Long = &H0
Private Const CSIDL_INTERNET As Long = &H1
Private Const CSIDL_PROGRAMS As Long = &H2
Private Const CSIDL_CONTROLS As Long = &H3
Private Const CSIDL_PRINTERS As Long = &H4
Private Const CSIDL_PERSONAL As Long = &H5
Private Const CSIDL_FAVORITES As Long = &H6
Private Const CSIDL_STARTUP As Long = &H7
Private Const CSIDL_RECENT As Long = &H8
Private Const CSIDL_SENDTO As Long = &H9
Private Const CSIDL_BITBUCKET As Long = &HA 'reycle bin
Private Const CSIDL_STARTMENU As Long = &HB
Private Const CSIDL_MYDOCUMENTS As Long = &HC
Private Const CSIDL_MYMUSIC As Long = &HD
Private Const CSIDL_MYVIDEO As Long = &HE
Private Const CSIDL_UNUSED1 As Long = &HF '&HF not currently implemented
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Private Const CSIDL_DRIVES As Long = &H11
Private Const CSIDL_NETWORK As Long = &H12
Private Const CSIDL_NETHOOD As Long = &H13
Private Const CSIDL_FONTS As Long = &H14
Private Const CSIDL_TEMPLATES As Long = &H15
Private Const CSIDL_COMMON_STARTMENU As Long = &H16
Private Const CSIDL_COMMON_PROGRAMS As Long = &H17
Private Const CSIDL_COMMON_STARTUP As Long = &H18
Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Private Const CSIDL_APPDATA As Long = &H1A
Private Const CSIDL_PRINTHOOD As Long = &H1B
Private Const CSIDL_LOCAL_APPDATA As Long = &H1C
Private Const CSIDL_ALTSTARTUP As Long = &H1D
Private Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E
Private Const CSIDL_COMMON_FAVORITES As Long = &H1F
Private Const CSIDL_INTERNET_CACHE As Long = &H20
Private Const CSIDL_COOKIES As Long = &H21
Private Const CSIDL_HISTORY As Long = &H22
Private Const CSIDL_COMMON_APPDATA As Long = &H23
Private Const CSIDL_WINDOWS As Long = &H24
Private Const CSIDL_SYSTEM As Long = &H25
Private Const CSIDL_PROGRAM_FILES As Long = &H26
Private Const CSIDL_MYPICTURES As Long = &H27
Private Const CSIDL_PROFILE As Long = &H28
Private Const CSIDL_SYSTEMX86 As Long = &H29 'RISC only
Private Const CSIDL_PROGRAM_FILESX86 As Long = &H2A 'RISC only
Private Const CSIDL_PROGRAM_FILES_COMMON As Long = &H2B
Private Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C 'RISC only
Private Const CSIDL_COMMON_TEMPLATES As Long = &H2D
Private Const CSIDL_COMMON_DOCUMENTS As Long = &H2E
Private Const CSIDL_COMMON_ADMINTOOLS As Long = &H2F
Private Const CSIDL_ADMINTOOLS As Long = &H30
Private Const CSIDL_CONNECTIONS As Long = &H31
Private Const CSIDL_COMMON_MUSIC As Long = &H35
Private Const CSIDL_COMMON_PICTURES As Long = &H36
Private Const CSIDL_COMMON_VIDEO As Long = &H37
Private Const CSIDL_RESOURCES As Long = &H38
Private Const CSIDL_RESOURCES_LOCALIZED As Long = &H39
Private Const CSIDL_COMMON_OEM_LINKS As Long = &H3A
Private Const CSIDL_CDBURN_AREA As Long = &H3B
Private Const CSIDL_UNUSED2 As Long = &H3C '&H3C not currently implemented
Private Const CSIDL_COMPUTERSNEARME As Long = &H3D

Private Const CSIDCC_DESKTOP = &H0
Private Const MAX_LEN = MAX_PATH_Unicode '= 260

Private mstrSTARTFOLDER As String
'-----------------------------------------------
' API calls.
'-----------------------------------------------
#If VBA7 Then
Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As LongPtr, ByVal nFolder As Long, pidl As ITEMIDLIST) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BrowseInfo) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As LongPtr, ByVal Msg As Long, wParam As Any, lParam As Any) As LongPtr
#Else
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32.DLL" (ByVal hwndOwner As Long, ByVal Folder As Long, ByRef IDL As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32.DLL" (ByVal IDL As Long, ByVal Path As String) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32.DLL" (ByRef bi As BrowseInfo) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long

#End If

'---------------------------------------------------------------------------------------
Public Function BrowseFolders(strStartFolder As String) As String
BrowseFolders = DoBrowse(BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE, "Browse for Folder", strStartFolder)
End Function

'---------------------------------------------------------------------------------------
Private Function DoBrowse(ByVal lngFlags As Long, ByVal strTitle As String, ByVal strStartFolder As String) As String
    Dim stBif As BrowseInfo
    Dim strFolderPath As String
    #If VBA7 Then
    Dim lRet As Long
    Dim IDL As ITEMIDLIST
    Dim lngHandle As LongPtr
    #Else
    Dim lngHandle As Long
    #End If

    strFolderPath = Space(MAX_LEN)
    With stBif
      .Owner = 0
      .RootIdl = 0
      .DisplayName = Space(MAX_LEN)
      .Title = strTitle
      .flags = lngFlags
    End With
    If strStartFolder <> "" Then
      mstrSTARTFOLDER = strStartFolder & vbNullChar
      stBif.CallbackAddress = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
    End If

    lngHandle = SHBrowseForFolder(stBif)
    If (lngHandle <> 0) Then
      strFolderPath = Space(MAX_LEN)
      If (CBool(SHGetPathFromIDList(lngHandle, strFolderPath))) Then
        DoBrowse = TrimStringAtNull(strFolderPath)
      Else
        DoBrowse = TrimStringAtNull(strFolderPath = stBif.Title)
      End If
    End If
    Call GlobalFree(lngHandle)

End Function

Private Function TrimStringAtNull(ByVal strValue As String) As String

   Dim intPos As Integer

    intPos = InStr(strValue, vbNullChar)
    Select Case intPos
        Case Is > 1
            TrimStringAtNull = Left$(strValue, intPos - 1)
        Case 0
            TrimStringAtNull = intPos
        Case 1
            TrimStringAtNull = ""
    End Select

End Function

#If VBA7 Then
Private Function BrowseCallbackProc(ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, ByVal lP As LongPtr, ByVal pData As String) As LongPtr
#Else
Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal lP As Long, ByVal pData As Long) As Long
#End If
   On Error Resume Next
   Dim lpIDList As LongPtr
   Dim ret As Long
   Dim sBuffer As String
   Select Case uMsg
       Case BFFM_INITIALIZED
           Call SendMessage(Hwnd, BFFM_SETSELECTION, 1, ByVal mstrSTARTFOLDER)
       Case BFFM_SELCHANGED
           sBuffer = Space(MAX_PATH)
           ret = SHGetPathFromIDList(lP, sBuffer)
           If ret = 1 Then
              Call SendMessage(Hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
         End If
   End Select
   BrowseCallbackProc = 0
End Function
#If VBA7 Then
Private Function GetAddressofFunction(add As LongPtr) As LongPtr
#Else
Private Function GetAddressofFunction(add As Long) As Long
#End If
GetAddressofFunction = add
End Function

Sub MyTest()
    Dim str As String
    Dim strStartFolder As String
    strStartFolder = "c:\temp"
    'str = BrowseFolders = DoBrowse(BIF_RETURNONLYFSDIRS Or BIF_USENEWUI, "Browse for Folder", strStartFolder)
     str = DoBrowse(BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE Or BIF_EDITBOX Or BIF_BROWSEINCLUDEFILES, "Browse for Folder", strStartFolder)
    'str = DoBrowse(BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE, "Browse for Folder", strStartFolder)
    Debug.Print str
End Sub

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Anonymous — Sat, 06 Jun 2020 00:49:46 GMT

Thank you! after several hours tweaking different programs I found on the net, yours is the only which works fine ! (I have Autocad 2018 on Windows 10 64Bits)

However, I had to correct few things before I got it to work:

- "Private Type ****EMID" should be "Private Type EMID"

- "mkid As ****EMID" should be "mkid As EMID"

- As the default path "c:\temp" may not exist on Windows 10, strStartFolder = "c:\temp" should be preferably strStartFolder = "c:\"

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

arievanbrakel6314 — Wed, 10 Jun 2020 09:03:24 GMT

you are right ***** should be S H I T E M I D

https://docs.microsoft.com/en-us/windows/win32/api/shtypes/ns-shtypes-shitemid

someone ADSK moderator has found a forbidden word!

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Tarek_K — Wed, 10 Jun 2020 09:05:24 GMT

Hi @arievanbrakel6314 ,

I adjusted the link so it actually can be used! But I can ensure you that no one edited it manually but rather an automatism that xxx-out these kind of word took action (which is definitely useful to have but on your rare occasion it wasn´t. ;))

Nevertheless - it should work now to use the link! Hope that helps.

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Anonymous — Wed, 10 Jun 2020 09:28:16 GMT

Went way over my head! Now I understand why you used *****. Thanks for your reply.

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Ed__Jobe — Tue, 29 Sep 2020 22:08:41 GMT

For me, (using 2018) AutoCAD crashes when calling SHBrowseInfo. It makes it to the callback procedure and crashes.

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

arievanbrakel6314 — Wed, 30 Sep 2020 07:25:01 GMT

Did you exactly copy over the code of this example?

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Ed__Jobe — Wed, 30 Sep 2020 14:13:46 GMT

Yes. I don't know if its something on my pc though. I've tried a few samples I found and it always crashes AutoCAD when calling SHGetPathFromDList. Is it still working for you?

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

Ed__Jobe — Thu, 01 Oct 2020 16:51:29 GMT

My mistake. I was calling it wrong. It's working.

Re: 64 Bit Win API Call - SHBrowseForFolder / SHGetPathFromDList

mucip — Mon, 08 Feb 2021 06:58:30 GMT

Hi,
Works like a charm. Thanks.

Regards,
Mucip:)