社区 › VB › 64位VBA 7.1中的“浏览文件夹”系统对话框

Patch61 发表于 2014-8-7 01:33:50

64位VBA 7.1中的“浏览文件夹”系统对话框

此模块将允许您在 64 位 VBA 7.1 中使用 Windows 系统 SHBrowseForFolder 对话框。

'##########################################################################################
'#                                                                                        #
'#                              modFolderBrowse                                       #
'#                               code compiled by                                       #
'#                              Steven Elliott                                          #
'#                        from many sources on the net                                  #
'#                           Released to Public Domain                                    #
'#                                                                                        #
'##########################################################################################
Option Explicit
      
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 Long, ByVal lpBuffer As String) As Long

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 Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Const BIF_RETURNONLYFSDIRSAs Long = 1
Private Const CSIDL_DRIVES          As Long = &H11
Private Const WM_USER               As Long = &H400
Private Const MAX_PATH            As Long = 260 ' Is it a bad thing that I memorized this value?
'// message from browser
Private Const BFFM_INITIALIZED   As Long = 1
Private Const BFFM_SELCHANGED      As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN      As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA   As Long = WM_USER + 100
Private Const BFFM_ENABLEOK         As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA    As Long = WM_USER + 102
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
      
Public Type BrowseInfo
hWndOwner As LongPtr
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As LongPtr
lParam As LongPtr
iImage As Long
End Type
Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
PtrToFunction = lFcnPtr
End Function
Private Function CorrectPath(ByVal sPath As String) As String
If Right$(sPath, 1) = "\" Then
    If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
Else
    If Len(sPath) = 2 Then sPath = sPath & "\"                  ' Append backslash to root
End If
CorrectPath = sPath
End Function
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 = BIF_RETURNONLYFSDIRS
If FolderExists(sPath) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
bi.lParam = StrPtr(sPath)
pItem = SHBrowseForFolder(bi)

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

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

End Function
Public Function BFFCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal sData As String) As Long
If uMsg = BFFM_INITIALIZED Then
    SendMessageA hWnd, BFFM_SETSELECTIONA, True, ByVal sData
End If
End Function
Public Function FolderExists(ByVal sFolderName As String) As Boolean
   Dim att As Long
   On Error Resume Next
   att = GetAttr(sFolderName)
   If Err.Number = 0 Then
      FolderExists = True
   Else
      Err.Clear
      FolderExists = False
   End If
   On Error GoTo 0
End Function

将其与下面的简单调用一起使用：

Private Sub cmdGetLibraryPath_Click()
   Dim sPath As String
'                        FolderBrowse(DialogBoxTitle, StartingPath)
   sPath = modFolderBrowse.FolderBrowse("Select Folder Containing Block Library", txtLibraryPath.Text)
   If sPath"" Then
      If modFolderBrowse.FolderExists(sPath) Then
         txtLibraryPath.Text = sPath
      End If
   End If
End Sub

**** Hidden Message *****

zzyong00 发表于 2015-4-29 11:28:21

太好了！
你能在64位VBA7.1中实现“opendialog”和“savedialog”吗？

57gmc 发表于 2020-9-29 17:36:58

代码在此行上使AutoCAD崩溃：
如果SHGetPathFromIDList（pItem，sFullPath）然后

Keith™ 发表于 2020-10-5 09:52:54

翻译错误代码（429）：请求 QPS 超过限制。

57gmc 发表于 2020-10-5 19:15:32

翻译错误代码（429）：请求 QPS 超过限制。

查看完整版本: 64位VBA 7.1中的“浏览文件夹”系统对话框