使用 vba 在打开的 ACAD 应用程序中打开 AUTOCAD dwg 文件

Question

我有一个列中列出零件编号的 Excel 文件。运行时，代码会拆分输入的第一个部件号。从前半部分代码找到包含该类别零件号的子文件夹，然后后半部分是实际文件名。示例01T-1001-01。 01T 是子文件夹名称，1001-01 是文件名，它在- 处拆分。但是，有时会在括号中添加零件的描述，例如1001-01 (Chuck)。这就是外卡的用途。

代码应该首先检查 AutoCAD 是否打开，如果是，则在打开的 AutoCAD 应用程序中打开 dwg，如果没有，则打开一个新应用程序。

问题是它会打开一个绘图（列表中的第一个），但会出错并显示“运行时错误'438'：对象不支持此属性或方法”它不会继续通过Set ACADApp.ActiveDocument = ACADApp.Documents.Open(ACADPath) 到打开列表中的其他 dwgs

更新代码如下：

Dim ACADApp As AcadApplication
Dim ACADPath As String
Dim ACAD As Object
Dim NFile As Object
Sub Open_Dwg()

Dim Wildcard As String
Dim path As String
Dim target As String
Dim SplitString() As String
Dim i As Integer
Dim a As Integer

i = 1

If ACAD Is Nothing Then
    Set ACAD = CreateObject("AutoCad.Application")

    If ACAD Is Nothing Then
        MsgBox "Could not start AutoCAD.", vbCritical
        Exit Sub
    End If
    Else
        Set ACAD = GetObject(, "AutoCAD.Application")
End If

Set ACADApp = ACAD
ACADApp.Visible = True

Do Until Cells(i, 1).Value = ""
ACADPath = ""
Wildcard = ""
OpenString = ""

path = "C:\Users\aholiday\Desktop\DEMO" 'Root Folder
target = Cells(i, 1).Value 'Get Targeted Cell Value
target = UCase(target) 'All Letters to Upper Case
SplitString() = Split(target, "-", 2) 'Split given name to obtain subfolder and name
path = path & "\" & SplitString(0) & "\" 'Build Complete Path

OpenString = path & SplitString(1) & ".dwg" 'File Path and Name
Wildcard = Dir(path & SplitString(1) & "*.dwg") 'File Path and Wildcard

If Dir(OpenString) <> "" Then
        ACADPath = OpenString
        OpenFile (ACADPath)
    Else
            If Wildcard <> "" Then 'If Not Then Use Wildcard
                ACADPath = path & Wildcard
                OpenFile (ACADPath)
            Else
                MsgBox ("File " & target & " Not Found")
            End If
    End If
i = i + 1
Loop
End Sub

Function OpenFile(ByVal ACADPath As String) As String
    Set ACADApp.ActiveDocument = ACADApp.Documents.Open(ACADPath)
End Function

Answer 1

这是我在生产应用程序中使用的基本外壳：

Sub Open_Dwg()
   On Error Resume Next

   Dim ACADApp As AcadApplication
   Dim a As Object

   Set a = GetObject(, "AutoCAD.Application")

   If a Is Nothing Then
      Set a = CreateObject("AutoCAD.Application")

      If a Is Nothing Then
         MsgBox "AutoCAD must be running before performing this action.", vbCritical
         Exit Sub
      End If
   End If

   Set ACADApp = a
   ACADApp.Visible = True
   Set ACADApp.ActiveDocument = ACADApp.Documents.Open("<your filename>")
End Sub

注意对 GetObject 调用的修改以及文档的打开方式。

编辑：

以上述代码为起点并将其应用于 OP 的代码，您将得到以下结果：

Option Explicit

Dim ACADApp As AcadApplication
Dim ACADPath As String
Dim ACAD As Object
Dim NFile As Object

Sub Open_Dwg()
   Dim Wildcard As String
   Dim OpenString As String
   Dim path As String
   Dim target As String
   Dim SplitString() As String
   Dim i As Integer
   Dim a As Integer

   'get or create an instance of autocad
   On Error Resume Next
   Set ACAD = Nothing
   Set ACAD = GetObject(, "AutoCAD.Application")

   If ACAD Is Nothing Then
      Set ACAD = CreateObject("AutoCad.Application")

      If ACAD Is Nothing Then
         MsgBox "Could not start AutoCAD.", vbCritical
         Exit Sub
      End If
   End If

   Set ACADApp = ACAD
   ACADApp.Visible = True
   On Error GoTo 0

   'process files
   i = 1

   Do Until Cells(i, 1).Value = ""
      path = "C:\Users\aholiday\Desktop\DEMO" 'Root Folder
      target = UCase(Cells(i, 1).Value) 'Get Targeted Cell Value
      SplitString() = Split(target, "-", 2) 'Split given name to obtain subfolder and name
      path = path & "\" & SplitString(0) & "\" 'Build Complete Path
      OpenString = path & SplitString(1) & ".dwg" 'File Path and Name
      Wildcard = Dir(path & SplitString(1) & "*.dwg") 'File Path and Wildcard

      If Dir(OpenString) <> "" Then
         OpenFile OpenString
      Else
         If Wildcard <> "" Then 'If Not Then Use Wildcard
            OpenFile path & Wildcard
         Else
            MsgBox ("File " & target & " Not Found")
         End If
      End If

      i = i + 1
   Loop
End Sub

Function OpenFile(ByVal ACADPath As String) As String
    ACADApp.Documents.Open ACADPath
End Function