vba实现CAD块属性导出到excel中

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