64位Windows操作系统下Autocad VBA通用文件夹对话框代码

对话框代码"/>

64位Windows操作系统下Autocad VBA通用文件夹对话框代码

 以下代码为浏览文件夹对话框通用代码，返回文件夹。

'Code courtesy of Terry KreftPrivate Type BROWSEINFOhOwner As LongPtrpidlRoot As LongPtrpszDisplayName As StringlpszTitle As StringulFlags As Longlpfn As LongPtrlParam As LongPtriImage As LongEnd TypePrivate Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As LongPrivate Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function BrowseDirectory(szDialogTitle As String) As String
On Error GoTo Err_BrowseDirectoryDim X As Long, bi As BROWSEINFO, dwIList As LongDim szPath As String, wPos As IntegerWith bi'.hOwner = hWndAccessApp.lpszTitle = szDialogTitle.ulFlags = BIF_RETURNONLYFSDIRSEnd WithdwIList = SHBrowseForFolder(bi)szPath = Space$(512)X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)If X ThenwPos = InStr(szPath, Chr(0))BrowseDirectory = Left$(szPath, wPos - 1)ElseBrowseDirectory = ""End If
Exit_BrowseDirectory:Exit Function
Err_BrowseDirectory:MsgBox Err.Number & " - " & Err.DescriptionResume Exit_BrowseDirectory
End Function
Public Sub TestOpeningDirectory()
On Error GoTo Err_TestOpeningDirectoryDim sDirectoryName As StringsDirectoryName = BrowseDirectory("Find and select where to export the Excel report files.")If sDirectoryName <> "" Then MsgBox "You selected the '" & sDirectoryName & "' directory.", vbInformationExit_TestOpeningDirectory:Exit SubErr_TestOpeningDirectory:MsgBox Err.Number & " - " & Err.DescriptionResume Exit_TestOpeningDirectory
End Sub