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

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

<P>我在论坛上下载了一段明细表输出为excel表格的程序，但程序有问题，执行不通，我以前没用过VBA。另外，我还想问问，我想用lisp实现绘图，但不知在VLISP怎么调用这段VBA代码，特请大家指教。代码如下：</P>
<P>我用的是EXCEL2003版本，CAD2006,引用选择的是<FONT face=宋体>"</FONT>Microsoft Excel&nbsp;11.0 Object Library"</P>
<P>Dim ExcelApp As Excel.Application</P>
<P>'激活要与之通信的Excel应用程序</P>
<P>On Error Resume Next</P>
<P>Set ExcelApp = GetObject(, "Excel.Application")</P>
<P>If Err &lt;&gt; 0 Then</P>
<P>Set ExcelApp = CreateObject("Excel.Applicationn")</P>
<P>End If</P>

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