从Excel使用AutoCad的ObjectDBX

'Excel Code!
'Modified April 1, 2006 by Jeff Mishler to demonstrate the use of ObjectDBX.
'      ActiveX Sample
'
'      Copyright (C) 1997, 1999, 2002 by Autodesk, Inc.
'
'      Permission to use, copy, modify, and distribute this software
'      for any purpose and without fee is hereby granted, provided
'      that the above copyright notice appears in all copies and
'      that both that copyright notice and the limited warranty and
'      restricted rights notice below appear in all supporting
'      documentation.
'
'      AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
'      AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
'      MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
'      DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
'      UNINTERRUPTED OR ERROR FREE.
'
'      Use, duplication, or disclosure by the U.S. Government is subject to
'      restrictions set forth in FAR 52.227-19 (Commercial Computer
'      Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
'      (Rights in Technical Data and Computer Software), as applicable.
Option Explicit
Sub Extract()
    Dim sheet As Object
    Dim elem As Object
    Dim excel As Object
    Dim excelSheet As Object
    Dim RowNum As Integer
    Dim Array1 As Variant
    Dim Count As Integer
    Dim acad As Object
    Dim doc As Object
    Dim mSpace As Object
    Dim NumberOfAttributes As Integer
    Dim AcadRunning As Boolean
    
    Set excel = GetObject(, "Excel.Application")
    Worksheets("Attributes").Activate
    Set excelSheet = excel.ActiveWorkbook.Sheets("Attributes")
    excelSheet.Range(Cells(1, 1), Cells(1000, 100)).Clear
    excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True
    Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err  0 Then
        Set acad = CreateObject("AutoCAD.Application")
        acad.Visible = False
        AcadRunning = False
        'MsgBox "Please open a drawing file and then restart this macro."
        'Exit Sub
    Else
        AcadRunning = True
    End If
    On Error GoTo 0 'Err_Handler
    If acad.Version Like "16*" Then
        Set doc = acad.getinterfaceobject("ObjectDBX.AxDbDocument.16")
    ElseIf acad.Version Like "17*" Then
        Set doc = acad.getinterfaceobject("ObjectDBX.AxDbDocument.17")
    Else
        Set doc = acad.getinterfaceobject("ObjectDBX.AxDbDocument")
    End If
    doc.Open "C:\Temp\Att-Test.dwg"
    RowNum = 1
    Dim Header As Boolean
    Header = False
    Dim oBlock As Object
    Dim oLayout As Object
    For Each oLayout In doc.Layouts
        If oLayout.Name  "Model" Then
        Set oBlock = oLayout.block
        For Each elem In oBlock
            With elem
                If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                   If UCase(.Name) = "TDG" Then
                    If .HasAttributes Then
                        Array1 = .GetAttributes
                        For Count = LBound(Array1) To UBound(Array1)
                            If Header = False Then
                                If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                                    excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
                                End If
                            End If
                        Next Count
                        RowNum = RowNum + 1
                        For Count = LBound(Array1) To UBound(Array1)
                            excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
                        Next Count
                        Header = True
                    End If
                    End If
                End If
            End With
        Next elem
        End If
    Next oLayout
    NumberOfAttributes = RowNum - 1
    If NumberOfAttributes > 0 Then
        Worksheets("Attributes").Range("A1").Sort _
        key1:=Worksheets("Attributes").Columns("A"), _
        Header:=xlGuess
    Else
        MsgBox "No attributes found in the current drawing."
    End If
    Set doc = Nothing
    If AcadRunning = False Then acad.Quit
    Set acad = Nothing
    Exit Sub
Err_Handler:
    Debug.Print Err.Number & " - " & Err.Description
    Err.Clear
    If AcadRunning = False Then acad.Quit
End Sub