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