cad vba 打开excel并弹窗打开指定文件

 CAD vba 代码实现打开excel,并通过对话框选择xls文件，并打开此文件进行下一步操作。代码如下:

excel.activeworkbook.sheets(1) ''

excel对象下activeworkbook,再往下是sheets对象，(1)为第一个表，

thisworkbook是vba代码所在的工作簿。

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 BROWSEINFOhOwner As LongPtrpidlRoot As LongPtrpszDisplayName As StringlpszTitle As StringulFlags As LongPtrlpfn As LongPtrlParam As LongPtriImage As LongPtr
End Type
Private Type tsFileNamelStructSize As LonghwndOwner As LongPtrhInstance As LongPtrstrFilter As StringstrCustomFilter As StringnMaxCustFilter As LongnFilterIndex As LongstrFile As StringnMaxFile As LongstrFileTitle As StringnMaxFileTitle As LongstrInitialDir As StringstrTitle As Stringflags As LongnFileOffset As IntegernFileExtension As IntegerstrDefExt As StringlCustData As LonglpfnHook As LongPtrlpTemplateName 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 = &H100000Public 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_ErrDim tsFN As tsFileNameDim strFileTitle As StringDim 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 functionWith 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 = 0End With' Call the function in the windows APIfResult = ts_apiGetOpenFileName(tsFN)If fResult Thenrlngflags = tsFN.flagsGOFN = tsTrimNull(tsFN.strFile)ElseGOFN = NullMsgBox "您未选择"EndEnd IfEnd 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_ErrDim tsFN As tsFileNameDim strFileTitle As StringDim 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 functionWith 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 = 0End WithfResult = ts_apiGetSaveFileName(tsFN)If fResult Thenrlngflags = tsFN.flagsGSFN = tsTrimNull(tsFN.strFile)ElseGSFN = NullMsgBox "您未保存"EndEnd IfEnd Function' Trim Nulls from a string returned by an API call.
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_ErrDim I As IntegerI = InStr(strItem, vbNullChar)If I > 0 ThentsTrimNull = Left(strItem, I - 1)ElsetsTrimNull = strItemEnd IftsTrimNull_End:On Error GoTo 0Exit FunctiontsTrimNull_Err:BeepMsgBox Err.Description, , "Error: " & Err.Number _& " in function basBrowseFiles.tsTrimNull"Resume tsTrimNull_EndEnd FunctionPublic Function GOFOLDER() As String
On Error GoTo Err_GOFOLDERDim x As LongPtr, bi As BROWSEINFO, dwIList As LongPtrDim szPath As String, wPos As IntegerWith bi'.hOwner = hWndAccessApp.lpszTitle = "请选择文件夹".ulFlags = BIF_RETURNONLYFSDIRSEnd WithdwIList = SHBrowseForFolder(bi)szPath = Space$(512)x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)If x ThenwPos = InStr(szPath, Chr(0))GOFOLDER = Left$(szPath, wPos - 1)ElseGOFOLDER = ""MsgBox "您未选择"EndEnd If
Exit_GOFOLDER:Exit Function
Err_GOFOLDER:MsgBox Err.Number & " - " & Err.DescriptionResume 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 OPENFILENAMElStructSize As LonghwndOwner As LonghInstance As LonglpstrFilter As StringlpstrCustomFilter As StringnMaxCustFilter As LongnFilterIndex As LonglpstrFile As StringnMaxFile As LonglpstrFileTitle As StringnMaxFileTitle As LonglpstrInitialDir As StringlpstrTitle As Stringflags As LongnFileOffset As IntegernFileExtension As IntegerlpstrDefExt As StringlCustData As LonglpfnHook As LonglpTemplateName As String
End Type
Public Type BROWSEINFOhOwner As LongpidlRoot As LongpszDisplayName As StringlpszTitle As StringulFlags As Longlpfn As LonglParam As LongiImage As Long
End TypeFunction 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 Thenpos = InStr(path, Chr(0))GOFOLDER = Left(path, pos - 1)
ElseGOFOLDER = ""MsgBox "您未选择"End
End If
End Function
Function GOFN() As StringDim sOFN As OPENFILENAMEWith 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 = 1025End WithDim sFileName As StringIf GetOpenFileName(sOFN) <> 0 ThenWith sOFNsFileName = Trim(.lpstrFile)GOFN = Left(sFileName, Len(sFileName) - 1)End WithElseGOFN = ""MsgBox "您已取消，请重新选择"EndEnd If
End Function
Function GSFN() As StringDim sSFN As OPENFILENAMEWith 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 = 1025End WithDim sFileName As StringIf GetSaveFileName(sSFN) <> 0 ThenWith sSFNsFileName = Trim(.lpstrFile)GSFN = Left(sFileName, Len(sFileName) - 1)End WithElseGSFN = ""MsgBox "您已取消，请重新选择"EndEnd If
'    Debug.Print GSFN, Len(GSFN)End Function
#End IfSub CAD打开excel_cadvba实现()
Dim excel As Object
Dim excelSheet As Object' Start ExcelOn Error Resume NextSet excel = GetObject(, "Excel.Application")If Err <> 0 ThenErr.ClearSet excel = CreateObject("Excel.Application")If Err <> 0 ThenMsgBox "Could not load Excel.", vbExclamationEndEnd IfEnd Ifexcel.Visible = True
'    MsgBox GOFNexcel.Workbooks.Open FileName:=GOFN
'    On Error GoTo errorcontrol
'errorcontrol: MsgBox Err.Number & " - " & Err.Description
'EndEnd Sub