AutoCad+vb+excel+CopyFromRecordset

兰州人

遍历图形文件的所有实体数据到excel,
用CopyFromRecordset效率要比用ExcelAndMdbData.xlSheet.Cells(ii, 1) = .Backward方法快数据倍.
遍历图形实体数据后,用CopyFromRecordset到excel用时为
遍历图形实体数据到数据集,用时:21:35:03-21:36:35
数据集:用CopyFromRecordset到excel用时为 21:36:35 -- 21:36:35
而用逐行逐列循环,将ExcelAndMdbData.xlSheet.Cells(ii, 1) = .Backward输到excel,用时约3分钟.
程序如下:

2. [code]Option Explicit
3. Dim boo As Boolean
4. Dim obj_Acad As Object, obj_Doc As Object, obj_ModelSpace As Object
5. Const RadianToDegree As Double = 180 / 3.1415926535897
6. Const DegreeToRadian As Double = 3.1415926535897 / 180
7. Const Pi = 3.1415926535897
8. Dim BaseGraphic As New BaseGraphic
9. Dim ExcelAndMdbData As New ExcelAndMdbData
10. Public Function rr()
11.   Debug.Print Time()
12.   Dim Ent As Object
13.   Dim ii As Integer, jj As Integer
14.   Dim TitleVar As Variant
15.   Dim adoRecordset     As ADODB.Recordset, rs As ADODB.Recordset
16.   ''
18.   TitleVar = Array("Backward", "Height", "InsertionPoint0", "InsertionPoint(1)", "InsertionPoint(2)", "Layer", "Linetype", "LinetypeScale", "Lineweight", "ObliqueAngle", "OwnerID", "PlotStyleName", "Rotation", "ScaleFactor", "StyleName", "TextAlignmentPoint(0)", "TextAlignmentPoint(1)", "TextAlignmentPoint(2)", "Alignment", "TextString", "Visible")
19.   For jj = 0 To 20
20.     ExcelAndMdbData.xlSheet.Cells(1, jj + 1) = TitleVar(jj)
21.   Next jj
22.   
23.   
24.   Dim pp As Variant, ppp As Variant
25.   Dim ExcelData As Variant
26.    '根据数组的大小初始化记录集
27.    Set adoRecordset = New ADODB.Recordset
28.    Set rs = New ADODB.Recordset
29.   ''
30.   
31.   For jj = 0 To 20
32.     'adoRecordset.Fields.Append TitleVar(jj), adVariant, , adFldMayBeNull
33.     adoRecordset.Fields.Append TitleVar(jj), adBSTR
34. 特别关注:
35. , adVariant, , adFldMayBeNull---------出现如下错误：对象‘CopyFromRecordset’的方法‘Range’失败   
36.    
37. 改为, adBSTR以下程序通过
40.   adoRecordset.Open
41.   ''数组到数据集
42.   
43.   
44.   ii = 0: jj = 1
45.   For Each Ent In BaseGraphic.obj_ModelSpace
46.     ReDim ExcelData(ii, 20)
47.     With Ent
48.    
49.       Select Case .ObjectName
50.         Case "AcDbText"
51.           adoRecordset.AddNew   '加n条记录,即为   DataGrid   添加n空行
52.           pp = .InsertionPoint
53.           ppp = .TextAlignmentPoint
54.           ii = ii
55.           adoRecordset.Fields(0) = .Backward
56.           adoRecordset.Fields(1) = .Height
57.           adoRecordset.Fields(2) = pp(0)
58.           adoRecordset.Fields(3) = pp(1)
59.           adoRecordset.Fields(4) = pp(2)
60.           adoRecordset.Fields(5) = .Layer
61.           adoRecordset.Fields(6) = .Linetype
62.           adoRecordset.Fields(8 - 1) = .LinetypeScale
63.           adoRecordset.Fields(9 - 1) = .Lineweight
64.           adoRecordset.Fields(10 - 1) = .ObliqueAngle
65.           adoRecordset.Fields(11 - 1) = .OwnerID
66.           adoRecordset.Fields(12 - 1) = .PlotStyleName
67.           adoRecordset.Fields(13 - 1) = .Rotation
68.           adoRecordset.Fields(14 - 1) = .ScaleFactor
69.           adoRecordset.Fields(15 - 1) = .StyleName
70.           adoRecordset.Fields(16 - 1) = ppp(0)
71.           adoRecordset.Fields(17 - 1) = ppp(1)
72.           adoRecordset.Fields(18 - 1) = ppp(2)
73.           adoRecordset.Fields(19 - 1) = .TextString
74.           adoRecordset.Fields(20 - 1) = .Alignment
75.           'adoRecordset.Fields(21 - 1) = .UpsideDown
76.           adoRecordset.Fields(21 - 1) = .Visible
77.      '     ExcelAndMdbData.xlSheet.Cells(ii, 0) = .ObjectName
78.           ii = ii + 1
79.       End Select
80.       
81.     End With
82.    
83.   Next Ent
84.   Debug.Print Time
85.   rs.Fields.Append "aa", adBSTR
86.   rs.Open
87.   rs.AddNew
88.   rs.Fields(0).Value = "aaaa"
89.   'ExcelAndMdbData.xlSheet.Cells(2, 1).CopyFromRecordset rs
90.   ExcelAndMdbData.xlSheet.Range("A2").CopyFromRecordset adoRecordset
91.   Debug.Print Time()
92. End Function

[code]Option Explicit Dim boo As Boolean Dim obj_Acad As Object, obj_Doc As Object, obj_ModelSpace As Object Const RadianToDegree As Double = 180 / 3.1415926535897 Const DegreeToRadian As Double = 3.1415926535897 / 180 Const Pi = 3.1415926535897 Dim BaseGraphic As New BaseGraphic Dim ExcelAndMdbData As New ExcelAndMdbData Public Function rr()   Debug.Print Time()   Dim Ent As Object   Dim ii As Integer, jj As Integer   Dim TitleVar As Variant   Dim adoRecordset     As ADODB.Recordset, rs As ADODB.Recordset   ''   TitleVar = Array("Backward", "Height", "InsertionPoint0", "InsertionPoint(1)", "InsertionPoint(2)", "Layer", "Linetype", "LinetypeScale", "Lineweight", "ObliqueAngle", "OwnerID", "PlotStyleName", "Rotation", "ScaleFactor", "StyleName", "TextAlignmentPoint(0)", "TextAlignmentPoint(1)", "TextAlignmentPoint(2)", "Alignment", "TextString", "Visible")   For jj = 0 To 20     ExcelAndMdbData.xlSheet.Cells(1, jj + 1) = TitleVar(jj)   Next jj         Dim pp As Variant, ppp As Variant   Dim ExcelData As Variant    '根据数组的大小初始化记录集    Set adoRecordset = New ADODB.Recordset    Set rs = New ADODB.Recordset   ''      For jj = 0 To 20     'adoRecordset.Fields.Append TitleVar(jj), adVariant, , adFldMayBeNull     adoRecordset.Fields.Append TitleVar(jj), adBSTR 特别关注: , adVariant, , adFldMayBeNull---------出现如下错误：对象‘CopyFromRecordset’的方法‘Range’失败        改为, adBSTR以下程序通过   adoRecordset.Open   ''数组到数据集         ii = 0: jj = 1   For Each Ent In BaseGraphic.obj_ModelSpace     ReDim ExcelData(ii, 20)     With Ent           Select Case .ObjectName         Case "AcDbText"           adoRecordset.AddNew   '加n条记录,即为   DataGrid   添加n空行           pp = .InsertionPoint           ppp = .TextAlignmentPoint           ii = ii           adoRecordset.Fields(0) = .Backward           adoRecordset.Fields(1) = .Height           adoRecordset.Fields(2) = pp(0)           adoRecordset.Fields(3) = pp(1)           adoRecordset.Fields(4) = pp(2)           adoRecordset.Fields(5) = .Layer           adoRecordset.Fields(6) = .Linetype           adoRecordset.Fields(8 - 1) = .LinetypeScale           adoRecordset.Fields(9 - 1) = .Lineweight           adoRecordset.Fields(10 - 1) = .ObliqueAngle           adoRecordset.Fields(11 - 1) = .OwnerID           adoRecordset.Fields(12 - 1) = .PlotStyleName           adoRecordset.Fields(13 - 1) = .Rotation           adoRecordset.Fields(14 - 1) = .ScaleFactor           adoRecordset.Fields(15 - 1) = .StyleName           adoRecordset.Fields(16 - 1) = ppp(0)           adoRecordset.Fields(17 - 1) = ppp(1)           adoRecordset.Fields(18 - 1) = ppp(2)           adoRecordset.Fields(19 - 1) = .TextString           adoRecordset.Fields(20 - 1) = .Alignment           'adoRecordset.Fields(21 - 1) = .UpsideDown           adoRecordset.Fields(21 - 1) = .Visible      '     ExcelAndMdbData.xlSheet.Cells(ii, 0) = .ObjectName           ii = ii + 1       End Select            End With       Next Ent   Debug.Print Time   rs.Fields.Append "aa", adBSTR   rs.Open   rs.AddNew   rs.Fields(0).Value = "aaaa"   'ExcelAndMdbData.xlSheet.Cells(2, 1).CopyFromRecordset rs   ExcelAndMdbData.xlSheet.Range("A2").CopyFromRecordset adoRecordset   Debug.Print Time() End Function

[/code]

2. Sub ls()
3.   Dim xlApp As Excel.Application
4.   Dim xlBook As Excel.Workbook
5.   Dim xlSheet As Excel.Worksheet
6.   Set xlApp = GetObject(, "Excel.Application") '创建EXCEL对象
7.   
8.   'Set xlBook = xlApp.Workbooks.Open("d:\Attribute.xls") '打开已经存
9.   xlApp.Visible = True '设置EXCEL对象可见（或不可见）
10.   Set xlSheet = xlApp.ActiveWorkbook.Sheets("sheet2")    'xlBook.Worksheets("Sheet2") '设置活动工作表，sheet1表示表名，可以使用字符型变量代替。
11.   xlSheet.Activate '激活工作表，让它处于前台活动中。
12.   Dim FileTitle
13.   FileTitle = Array("LineStartPoint0", "LineStartPoint1", "LineStartPoint2", "LineEndPoint0", "LineEndPoint1", "LineEndPoint2")
14.   For ii = 0 To UBound(FileTitle)
15.     xlSheet.Cells(1, ii + 1) = FileTitle(ii)
16.   Next ii
17.   Dim Ent As AcadEntity, EntLine As AcadLine
18.   Dim RowCount As Integer
19.   RowCount = 2
20.   For Each Ent In ThisDrawing.ModelSpace
21.     Select Case Ent.ObjectName
22.       Case "AcDbLine"
23.          Set EntLine = Ent
24.          For ii = 0 To 2
25.            xlSheet.Cells(RowCount, ii + 1) = EntLine.StartPoint(ii)
26.            xlSheet.Cells(RowCount, ii + 4) = EntLine.EndPoint(ii)
27.          Next
28.     End Select
29.     RowCount = RowCount + 1
30.   Next
31. End Sub

Sub ls()   Dim xlApp As Excel.Application   Dim xlBook As Excel.Workbook   Dim xlSheet As Excel.Worksheet   Set xlApp = GetObject(, "Excel.Application") '创建EXCEL对象      'Set xlBook = xlApp.Workbooks.Open("d:\Attribute.xls") '打开已经存   xlApp.Visible = True '设置EXCEL对象可见（或不可见）   Set xlSheet = xlApp.ActiveWorkbook.Sheets("sheet2")    'xlBook.Worksheets("Sheet2") '设置活动工作表，sheet1表示表名，可以使用字符型变量代替。   xlSheet.Activate '激活工作表，让它处于前台活动中。   Dim FileTitle   FileTitle = Array("LineStartPoint0", "LineStartPoint1", "LineStartPoint2", "LineEndPoint0", "LineEndPoint1", "LineEndPoint2")   For ii = 0 To UBound(FileTitle)     xlSheet.Cells(1, ii + 1) = FileTitle(ii)   Next ii   Dim Ent As AcadEntity, EntLine As AcadLine   Dim RowCount As Integer   RowCount = 2   For Each Ent In ThisDrawing.ModelSpace     Select Case Ent.ObjectName       Case "AcDbLine"          Set EntLine = Ent          For ii = 0 To 2            xlSheet.Cells(RowCount, ii + 1) = EntLine.StartPoint(ii)            xlSheet.Cells(RowCount, ii + 4) = EntLine.EndPoint(ii)          Next     End Select     RowCount = RowCount + 1   Next End Sub

xxxtttxxx

有注解就好了，研究一下

cnks

能否把dvb文件传上来

cnks

能否把dvb文件传上来

兰州人

用VB编的，有基本图形类模块和excel And Access类模块组成。

在VBA程序同样运行，只是将BaseGraphic.obj_ModelSpace改为Thisdrawing.ModelSpace而宜。
在此，给各位大侠出道题，就是如何将上面的程序，自己能够随心所欲得到应用。

1、AutoCAD+VBA与Excel有几种通迅方式：ADO,DAO,open

2、数据集的建立方式：SQL方式，以及实体变量数据直接赋值到数据集方式。如：

Dim TextRecordSet As ADODB.Recordset

Set TextRecordSet = New ADODB.Recordset

'设置Text数据集字段
  For jj = 0 To 22
    TextRecordSet.Fields.Append TextTitleVar(jj), adBSTR
  Next jj
  TextRecordSet.Open

  TextRecordSet.AddNew   '加n条记录

谢谢各位大侠的捧场，希望大家积极参与共同提高。

结论：CopyFromRecordset将采集到AutoCAD的实体数据，用数据集方式，将数据传递到excel,Access是一种比较快的数据传递方法。

muzi2005888

收下

学习一下

liusong0517

楼主真牛

shajianlin

没看懂！

askimol

好好学习一下