cad vba 打开excel并弹窗打开指定文件、通过fso弹窗打开dwg

yngsqq2024-03-25 16:31

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 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 CAD打开excel_cadvba实现()
Dim excel As Object
Dim excelSheet As Object
    ' Start Excel
    On Error Resume Next
    
    Set excel = GetObject(, "Excel.Application")
    
    If Err <> 0 Then
        Err.Clear
        Set excel = CreateObject("Excel.Application")
            
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
    excel.Visible = True
'    MsgBox GOFN
    excel.Workbooks.Open FileName:=GOFN
'    On Error GoTo errorcontrol
'errorcontrol: MsgBox Err.Number & " - " & Err.Description
'End

End Sub

若不想通过windows api方法 （代码太长），可通过引用office库，调用excel的fso函数弹窗返回路径名，然后可通过documents.open打开dwg文件。

复制代码 
Function cad引用打开dwg()
'前提是：工具------引用------打开Microsoft office库
'On Error Resume Next
Dim excel As Object
'Set scripting.filesystemobject = GetObject(, "scripting.filesystemobject.Application")

Set excel = CreateObject("excel.Application")
'excel.Visible = True
excel.workbooks.Add
With excel.FileDialog(msoFileDialogOpen)
    .Title = "请选择你要的文件"
    .AllowMultiSelect = True
    .InitialFileName = "C:\Users\Administrator\Desktop\"
    .Filters.Clear
    .Filters.Add "excel files", "*.xls,*.xlsx,*.dwg"
    If .show = True Then
    Set gof = .SelectedItems
'    .Execute '打开excel时启用
    Dim sname As String
    sname = gof.Item(1)
    Documents.Open sname
    excel.Quit '退出excel
    Else: Exit Function
    End If
End With
End Function

Sub a()
Call cad引用打开dwg
ZoomExtents
ThisDrawing.Regen acActiveViewport
End Sub

cad引用打开excel方法：

复制代码 
Function cad引用打开excel()
'前提是：工具------引用------打开Microsoft office库
'On Error Resume Next
Dim excel As Object
'Set scripting.filesystemobject = GetObject(, "scripting.filesystemobject.Application")

Set excel = CreateObject("excel.Application")
excel.Visible = True
excel.workbooks.Add
With excel.FileDialog(msoFileDialogOpen)
    .Title = "请选择你要的文件"
    .AllowMultiSelect = True
    .InitialFileName = "C:\Users\Administrator\Desktop\"
    .Filters.Clear
    .Filters.Add "excel files", "*.xls,*.xlsx,*.dwg"
    If .show = True Then
    Set gof = .SelectedItems
    .Execute '打开excel时启用
'    Dim sname As String
'    sname = gof.Item(1)
'    Documents.Open sname
'    excel.Quit '退出excel
    Else: Exit Function
    End If
End With
End Function

Sub a()
Call cad引用打开excel
End Sub
相关推荐
沉到海底去吧Go3 小时前
【行驶证识别成表格】批量OCR行驶证识别与Excel自动化处理系统，行驶证扫描件和照片图片识别后保存为Excel表格，基于QT和华为ocr识别的实现教程
自动化·ocr·excel·行驶证识别·行驶证识别表格·批量行驶证读取表格
Abigail_chow1 天前
EXCEL如何快速批量给两字姓名中间加空格
windows·microsoft·excel·学习方法·政务
xiaohezi1 天前
Rag chunk 之：Excel 文档解析
excel
weixin_472339462 天前
python批量解析提取word内容到excel
python·word·excel
源2 天前
Unity与Excel表格交互热更方案
unity·游戏引擎·excel
金融小白数据分析之路2 天前
Excel高级函数使用FILTER、UNIQUE、INDEX
excel
未来之窗软件服务2 天前
Excel表格批量下载 CyberWin Excel Doenlaoder 智能编程-——玄武芯辰
excel·批量下载·仙盟创梦ide·东方仙盟
阿斯加德的IT2 天前
Power Automate: 从Excel 选择列，每200条生成一个CSV文件并保存在sharepoint文档库
低代码·excel
步达硬件2 天前
【转bin】EXCEL数据转bin
excel
wtsolutions2 天前
JSON to Excel 3.0.0 版本发布 - 从Excel插件到Web应用的转变
json·excel·json-to-excel·wtsolutions
热门推荐
01YOLOv8入门 | 重要性能衡量指标、训练结果评价及分析及影响mAP的因素【发论文关注的指标】02KGG转MP3工具|非KGM文件|解密音频03从零安装 LLaMA-Factory 微调 Qwen 大模型成功及所有的坑04R-tree详解05【SpeedAI科研小助手】2分钟极速解决知网维普重复率、AIGC率过高，一键全文降！文件格式不变，公式都保留的！06DeepSeek各版本说明与优缺点分析07【无人机】无人机通信模块，无人机图数传模块的介绍，数传，图传，图传数传一体电台，08VMware虚拟机安装Win7专业版保姆级教程（附镜像包）09组基轨迹建模 GBTM的介绍与实现（Stata 或 R）10海康Visionmaster-常见问题排查方法-启动阶段