[求助][VBA]明细表输出

lichunling

我在论坛上下载了一段明细表输出为excel表格的程序，但程序有问题，执行不通，我以前没用过VBA。另外，我还想问问，我想用lisp实现绘图，但不知在VLISP怎么调用这段VBA代码，特请大家指教。代码如下：

我用的是EXCEL2003版本，CAD2006,引用选择的是"Microsoft Excel 11.0 Object Library"

Dim ExcelApp As Excel.Application

'激活要与之通信的Excel应用程序

On Error Resume Next

Set ExcelApp = GetObject(, "Excel.Application")

If Err <> 0 Then

Set ExcelApp = CreateObject("Excel.Applicationn")

End If

 
 Sub BlkAttr_Extract()
    Dim Excel   As Excel.Application
    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
    End If
    '创建一个新工作簿
    Set ExcelWorkbook = Excel.Workbooks.Add
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
    '将新创建的工作簿保存为Excel文件
    ExcelWorkbook.SaveAs "属性表.xls"
    '令Excel应用程序可见
    Dim RowNum   As Integer
    Dim Header   As Boolean
    Dim blkElem   As AcadEntity
    Dim Array1   As Variant
    Dim Count   As Integer
    RowNum = 1
    Header = False
    '遍历模型空间，查找明细表的每个块引用表行
      For bEach  blkElem  In  ThisDrawing.ModelSpace
        With blkElem
            '当一个块引用表行被找到后，检查它是否有属性
            If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                '如果有属性
                If .HasAttributes Then
                    '提取块引用中的属性
                    Array1 = .GetAttributes
                    '这一轮循环用来查找标题，如果有填在第1行
                    For Count = LBound(Array1) To UBound(Array1)
                        '如果还没有标题
                        If Header = False Then
                            '作为标题的明细行其块属性常设为Constant类型
                            If Array1(Count).Constant Then
                                ExcelSheet.Cells(RowNum, Count + 1).Value _
                                                = Array1(Count).TextString
                            End If
                        End If
                    Next Count
                    '从第2行开始，填写其它的明细表行内容
                    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 With
    Next blkElem
    '对填入当前表单的内容，按第1列进行排序,
    '范围是从A1单元格开始的整个工作表
    Excel.Worksheets("Sheet1").Range("A1").Sort _
        key1:=Excel.Worksheets("Sheet1").Columns("A"), _
        Header:=xlGuess
    '显示Excel工作表中的结果
    Excel.Visible = True
    '该语句用来等待查看显示结果
    MsgBox "按‘确定’键将关闭Excel的运行！"
    '保存传过来的数据
    ExcelWorkbook.Save
    '关闭Excel应用程序
    Excel.Application.Quit
    '删除Excel应用程序实例
    Set Excel = Nothing
End Sub