Select Folder using SHBrowseForFolderA does not work on windows 10 platform

Question

I have a vba7 macro which use a folder select box base on windows api. This code use SHBrowseForFolderA, SendMessageA, SHGetPathFromIDListA APIs

Upto now this code run perfectly on Windows 7 x64 platform. This code crash when I run it on win 10 x64 platform.

    'API Declares
    Public Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd   As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BrowseInfo) As Long
    Private Declare PtrSafe Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)



    Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sPath As String) As String
  Dim ReturnPath As String

  Dim b(MAX_PATH) As Byte
  Dim pItem       As Long
  Dim sFullPath   As String
  Dim bi          As BrowseInfo
  Dim ppidl       As Long

  sPath = CorrectPath(sPath)

  bi.hWndOwner = 0 'Screen.ActiveForm.hwnd

  'SHGetSpecialFolderLocation bi.hWndOwner, CSIDL_DRIVES, ppidl

  bi.pIDLRoot = 0 'ppidl

  bi.pszDisplayName = VarPtr(b(0))
  bi.lpszTitle = sDialogTitle
  bi.ulFlags = BF_Flags.BIF_RETURNONLYFSDIRS + BF_Flags.BIF_NEWDIALOGSTYLE + BF_Flags.BIF_STATUSTEXT              'BIF_RETURNONLYFSDIRS
  'bi.ulFlags = BF_Flags.BIF_RETURNONLYFSDIRS + BF_Flags.BIF_USENEWUI + BF_Flags.BIF_STATUSTEXT             'BIF_RETURNONLYFSDIRS

  If FolderExists(sPath) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
  bi.lParam = StrPtr(sPath)



  pItem = SHBrowseForFolderA(bi)

  If pItem Then ' Succeeded
    sFullPath = Space$(MAX_PATH)
    If SHGetPathFromIDListA(pItem, sFullPath) Then
      ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
      CoTaskMemFree pItem
    End If
  End If

'  If pItem <> 0 Then ' Succeeded
'    sFullPath = Space$(MAX_PATH_Unicode)
'    If SHGetPathFromIDListW(pItem, StrPtr(sFullPath)) Then
'      ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
'      CoTaskMemFree pItem 'nettoyage
'    End If
'  End If

  If Right$(ReturnPath, 1) <> "\" And ReturnPath <> "" Then  'Could be "C:"
    FolderBrowse = ReturnPath & "\"
  End If

'If Right$(ReturnPath, 1) <> "\" And ReturnPath <> "" Then  'Could be "C:"
'    FolderBrowse = ReturnPath & "\"
'  End If

End Function

I don't have any error message Just Catia application is frozen.

Regards

score 0 · Answer 1 · answered Aug 01 '19 at 09:13

I have finaly found how to solve this issue. The declaration was not correct

Here is the good declaration

'API Declares

    Public Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Boolean
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)

'BrowseInfo Type
    Public Type BROWSEINFO
        hWndOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfnCallback As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type

regards

Select Folder using SHBrowseForFolderA does not work on windows 10 platform

1 Answers1