vba实现CAD与excel交互功能可提高工作效率，此例可供参考。

vba6运行程序前需在vba ide中工具栏下引用选项中引用excel库方可运行,vba7可直接运行。

代码如下：

Sub 导出CAD块属性到excel()
    Dim Excel As Object
    Dim elem As Object
    Dim excelSheet As Object
    Dim Array1 As Variant
    Dim Count, RowNum As Integer
    Dim NumberOfAttributes As Integer
    
    ' 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 "不能加载excel", vbExclamation
            End
        End If
    End If
    
    On Error GoTo 0
    
    Excel.Visible = True
    Excel.Workbooks.Add
    Excel.Sheets("Sheet1").Select
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
    
    RowNum = 1
    Dim Header As Boolean
    For Each elem In ThisDrawing.ModelSpace
        If StrComp(elem.EntityName, "AcDbBlockReference", 1) = 0 Then
            If elem.HasAttributes Then
                Array1 = elem.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
    Next elem
    
    NumberOfAttributes = RowNum - 1
   
    If NumberOfAttributes > 0 Then
        excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True
        
        'For a specific set of attribute information this could
        'be set to fit the exact number of columns.
        excelSheet.Columns("A:G").AutoFit
        'Rename the worksheet
        Sheets("Sheet1").Name = "Attributes"
        If Chart.Value = True Then
            CreateChart (NumberOfAttributes)
        End If
        If Memo.Value = True Then
            MakeMemos
        End If
    Else
        MsgBox "当前图中未找到属性", vbInformation
        Excel.Quit
    End If

End Sub