windswolf 发表于 2004-12-28 15:23:00

请教！！在线等！！关于AutoCAD明细表提取!

我要将AutoCAD的明细表提取到Excel中去,我用的是AutoCAD2004和VB6.0;


我在网上找到了一个程序,在运行时提示错误,请帮忙看一下!!


谢谢!!!


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


<BR>

雪山飞狐_lzh 发表于 2004-12-29 21:06:00

<FONT color=#f73809>For bEach       ?</FONT>


<FONT color=#f73809>For Each       </FONT>

minging2005 发表于 2008-9-2 07:51:00

<div class="t_msgfont" id="postmessage_2653300">如果这样处理很难做到整套工程图一次性提取，即不能对一台设备一次性完成<br/>而且也很难有专业的技术人员长时间从事这个岗位的工作<br/><br/>有需要提取产品综合明细表的公司可以和我联系，我可以快速帮助你公司完成提取工作。<br/>当然可以提取特定的标准件、外购件等表，具体问题我们可以商谈。<br/>提高准确度——提高效率<br/>邮箱地址：<a href="mailto:minging2005@yahoo.com.cn">minging2005@yahoo.com.cn</a></div>
页: [1]
查看完整版本: 请教！！在线等！！关于AutoCAD明细表提取!