使用 SHBrowseForFolderA 选择文件夹在 Windows 10 平台上不起作用答案

【问题标题】：Select Folder using SHBrowseForFolderA does not work on windows 10 platform使用 SHBrowseForFolderA 选择文件夹在 Windows 10 平台上不起作用
【发布时间】：2019-07-31 13:46:49
【问题描述】：

我有一个 vba7 宏，它使用基于 windows api 的文件夹选择框。此代码使用 SHBrowseForFolderA、SendMessageA、SHGetPathFromIDListA API

到目前为止，此代码可以在 Windows 7 x64 平台上完美运行。当我在 win 10 x64 平台上运行此代码时，它会崩溃。

    '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

我没有任何错误信息只是 Catia 应用程序被冻结。

问候

【问题讨论】：

标签： vba api catia

【解决方案1】：

我终于找到了解决这个问题的方法。声明不正确

这是好的宣言

'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

问候

【讨论】：