社区 › VB › [求助][VBA]明细表输出

lichunling 发表于 2006-10-13 16:58:00

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

我在论坛上下载了一段明细表输出为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 Err0 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 Err0 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 bEachblkElemInThisDrawing.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

查看完整版本: [求助][VBA]明细表输出