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

windswolf

我要将AutoCAD的明细表提取到Excel中去,我用的是AutoCAD2004和VB6.0; 我在网上找到了一个程序,在运行时提示错误,请帮忙看一下!! 谢谢!!! 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

雪山飞狐_lzh

For bEach ? For Each

minging2005

如果这样处理很难做到整套工程图一次性提取，即不能对一台设备一次性完成
而且也很难有专业的技术人员长时间从事这个岗位的工作

有需要提取产品综合明细表的公司可以和我联系，我可以快速帮助你公司完成提取工作。
当然可以提取特定的标准件、外购件等表，具体问题我们可以商谈。
提高准确度——提高效率
邮箱地址：minging2005@yahoo.com.cn