通用（32位、64位） CAD VBA(6.0、7.0)实现打开、另存、选择文件夹对话框

2024-07-13 07:13| 来源: 网络整理| 查看: 265

vba可以调用windows API函数实现弹出打开文件、另存文件及选择文件夹对话框，然而低版本CAD（32位CAD，对应VBA6）写的代码到高版本CAD(64位，对应VBA7)往往运行不了，提示各种错误。

不同版本的VBA写出的DVB文件不能通用往往令人懊恼，而网上给出的解决办法也是只言片语，很难彻底解决这一难题。不要灰心，这里给出终极代码。

话不多说，先上效果图：

本人亲测，32位、64位CADVBA均可行，如有引用，请附上本文链接，注明出处，码字不易。

代码附上：

Option Explicit #If VBA7 Then Private Declare PtrSafe Function ts_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean Private Declare PtrSafe Function ts_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean Private Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias _ "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias _ "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr Private Const BIF_RETURNONLYFSDIRS = &H1 Private Type BROWSEINFO hOwner As LongPtr pidlRoot As LongPtr pszDisplayName As String lpszTitle As String ulFlags As LongPtr lpfn As LongPtr lParam As LongPtr iImage As LongPtr End Type Private Type tsFileName lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr strFilter As String strCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long strFile As String nMaxFile As Long strFileTitle As String nMaxFileTitle As Long strInitialDir As String strTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer strDefExt As String lCustData As Long lpfnHook As LongPtr lpTemplateName As String End Type ' Flag Constants Private Const tscFNAllowMultiSelect = &H200 Private Const tscFNCreatePrompt = &H2000 Private Const tscFNExplorer = &H80000 Private Const tscFNExtensionDifferent = &H400 Private Const tscFNFileMustExist = &H1000 Private Const tscFNPathMustExist = &H800 Private Const tscFNNoValidate = &H100 Private Const tscFNHelpButton = &H10 Private Const tscFNHideReadOnly = &H4 Private Const tscFNLongNames = &H200000 Private Const tscFNNoLongNames = &H40000 Private Const tscFNNoChangeDir = &H8 Private Const tscFNReadOnly = &H1 Private Const tscFNOverwritePrompt = &H2 Private Const tscFNShareAware = &H4000 Private Const tscFNNoReadOnlyReturn = &H8000 Private Const tscFNNoDereferenceLinks = &H100000 Public Function GOFN( _ Optional ByRef rlngflags As Long = 0&, _ Optional ByVal strInitialDir As String = "", _ Optional ByVal strFilter As String = "dwg文件 (*.dwg)" & vbNullChar & "*.dwg" _ & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*", _ Optional ByVal lngFilterIndex As Long = 1, _ Optional ByVal strDefaultExt As String = "", _ Optional ByVal strFileName As String = "", _ Optional ByVal strDialogTitle As String = "", _ Optional ByVal fOpenFile As Boolean = True) As Variant 'On Error GoTo GOFN_Err Dim tsFN As tsFileName Dim strFileTitle As String Dim fResult As Boolean ' Allocate string space for the returned strings. strFileName = Left(strFileName & String(256, 0), 256) strFileTitle = String(256, 0) ' Set up the data structure before you call the function With tsFN .lStructSize = LenB(tsFN) '.hwndOwner = Application.hWndAccessApp .strFilter = strFilter .nFilterIndex = lngFilterIndex .strFile = strFileName .nMaxFile = Len(strFileName) .strFileTitle = strFileTitle .nMaxFileTitle = Len(strFileTitle) .strTitle = strDialogTitle .flags = rlngflags .strDefExt = strDefaultExt .strInitialDir = strInitialDir .hInstance = 0 .strCustomFilter = String(255, 0) .nMaxCustFilter = 255 .lpfnHook = 0 End With ' Call the function in the windows API fResult = ts_apiGetOpenFileName(tsFN) If fResult Then rlngflags = tsFN.flags GOFN = tsTrimNull(tsFN.strFile) Else GOFN = Null MsgBox "您未选择" End End If End Function Public Function GSFN( _ Optional ByRef rlngflags As Long = 0&, _ Optional ByVal strInitialDir As String = "", _ Optional ByVal strFilter As String = "dwg文件 (*.dwg)" & vbNullChar & "*.dwg" _ & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*", _ Optional ByVal lngFilterIndex As Long = 1, _ Optional ByVal strDefaultExt As String = "", _ Optional ByVal strFileName As String = "", _ Optional ByVal strDialogTitle As String = "", _ Optional ByVal fOpenFile As Boolean = False) As Variant 'On Error GoTo tsGetFileFromUser_Err Dim tsFN As tsFileName Dim strFileTitle As String Dim fResult As Boolean ' Allocate string space for the returned strings. strFileName = Left(strFileName & String(256, 0), 256) strFileTitle = String(256, 0) ' Set up the data structure before you call the function With tsFN .lStructSize = LenB(tsFN) '.hwndOwner = Application.hWndAccessApp .strFilter = strFilter .nFilterIndex = lngFilterIndex .strFile = strFileName .nMaxFile = Len(strFileName) .strFileTitle = strFileTitle .nMaxFileTitle = Len(strFileTitle) .strTitle = strDialogTitle .flags = rlngflags .strDefExt = strDefaultExt .strInitialDir = strInitialDir .hInstance = 0 .strCustomFilter = String(255, 0) .nMaxCustFilter = 255 .lpfnHook = 0 End With fResult = ts_apiGetSaveFileName(tsFN) If fResult Then rlngflags = tsFN.flags GSFN = tsTrimNull(tsFN.strFile) Else GSFN = Null MsgBox "您未保存" End End If End Function ' Trim Nulls from a string returned by an API call. Private Function tsTrimNull(ByVal strItem As String) As String On Error GoTo tsTrimNull_Err Dim I As Integer I = InStr(strItem, vbNullChar) If I > 0 Then tsTrimNull = Left(strItem, I - 1) Else tsTrimNull = strItem End If tsTrimNull_End: On Error GoTo 0 Exit Function tsTrimNull_Err: Beep MsgBox Err.Description, , "Error: " & Err.Number _ & " in function basBrowseFiles.tsTrimNull" Resume tsTrimNull_End End Function Public Function GOFOLDER() As String On Error GoTo Err_GOFOLDER Dim x As LongPtr, bi As BROWSEINFO, dwIList As LongPtr Dim szPath As String, wPos As Integer With bi '.hOwner = hWndAccessApp .lpszTitle = "请选择文件夹" .ulFlags = BIF_RETURNONLYFSDIRS End With dwIList = SHBrowseForFolder(bi) szPath = Space$(512) x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath) If x Then wPos = InStr(szPath, Chr(0)) GOFOLDER = Left$(szPath, wPos - 1) Else GOFOLDER = "" MsgBox "您未选择" End End If Exit_GOFOLDER: Exit Function Err_GOFOLDER: MsgBox Err.Number & " - " & Err.Description Resume Exit_GOFOLDER End Function #Else Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As Long Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (lpofn As OPENFILENAME) As Long Declare Function SHBrowseForFolder Lib "SHELL32.DLL" (lpBrowseInfo As BROWSEINFO) As Long Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" (ByVal pidl As Long, ByVal pszPath As String) As Long Public choice As String Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Function GOFOLDER(Optional message) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0 bInfo.lpszTitle = "" bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) path = Space$(256) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr(0)) GOFOLDER = Left(path, pos - 1) Else GOFOLDER = "" MsgBox "您未选择" End End If End Function Function GOFN() As String Dim sOFN As OPENFILENAME With sOFN .lStructSize = Len(sOFN) .lpstrFilter = "dwg文件(*.dwg)" & Chr(0) & "*.dwg" & Chr(0) & "dxf文件(*.dxf)" & Chr(0) & "*.dxf" & Chr(0) & "Excel文件(*.xl*)" & Chr(0) & "*.xl*" & Chr(0) & "Word文件(*.do*)" _ & Chr(0) & "*.do*" & Chr(0) & "PPT文件(*.pp*)" & Chr(0) & "*.pp*" & Chr(0) & "所有文件(*.*)" & Chr(0) & "*.*" _ & Chr(0) & Chr(0) .lpstrFile = Space(1024) .nMaxFile = 1025 End With Dim sFileName As String If GetOpenFileName(sOFN) 0 Then With sOFN sFileName = Trim(.lpstrFile) GOFN = Left(sFileName, Len(sFileName) - 1) End With Else GOFN = "" MsgBox "您已取消，请重新选择" End End If End Function Function GSFN() As String Dim sSFN As OPENFILENAME With sSFN .lStructSize = Len(sSFN) '设置保存文件对话框中的文件筛选字符串对 .lpstrFilter = "dwg文件(*.dwg)" & Chr(0) & "*.dwg" & Chr(0) & "dxf文件(*.dxf)" & Chr(0) & "*.dxf" & Chr(0) & "Excel文件(*.xl*)" & Chr(0) & "*.xl*" & Chr(0) & "Word文件(*.do*)" _ & Chr(0) & "*.do*" & Chr(0) & "PPT文件(*.pp*)" & Chr(0) & "*.pp*" & Chr(0) & "所有文件(*.*)" & Chr(0) & "*.*" _ & Chr(0) & Chr(0) '设置文件完整路径和文件名的缓冲区 .lpstrFile = Space(1024) '设置文件完整路径和文件名的最大字符数,一定要比lpstrFile参数指定的字符数多1，用于存储结尾Null字符 .nMaxFile = 1025 End With Dim sFileName As String If GetSaveFileName(sSFN) 0 Then With sSFN sFileName = Trim(.lpstrFile) GSFN = Left(sFileName, Len(sFileName) - 1) End With Else GSFN = "" MsgBox "您已取消，请重新选择" End End If ' Debug.Print GSFN, Len(GSFN) End Function #End If Sub a() On Error GoTo errorcontrol MsgBox GOFOLDER Documents.Open GOFN ThisDrawing.SaveAs GSFN Exit Sub errorcontrol: MsgBox Err.Number & " - " & Err.Description End End Sub

【本文地址】

公司简介

联系我们