AutoCad+vb+excel+CopyFromRecordset

兰州人 发表于 2008-3-27 22:01:00

本帖最后由作者于 2008-5-5 15:26:32 编辑

遍历图形文件的所有实体数据到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分钟.
程序如下: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
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 发表于 2008-3-27 22:30:00

有注解就好了，研究一下

cnks 发表于 2008-3-28 12:05:00

能否把dvb文件传上来

cnks 发表于 2008-3-28 12:05:00

能否把dvb文件传上来

兰州人 发表于 2008-3-28 13:31:00

本帖最后由作者于 2008-3-28 14:30:27 编辑 用VB编的，有基本图形类模块和excel And Access类模块组成。在VBA程序同样运行，只是将BaseGraphic.obj_ModelSpace改为Thisdrawing.ModelSpace而宜。 在此，给各位大侠出道题，就是如何将上面的程序，自己能够随心所欲得到应用。1、AutoCAD+VBA与Excel有几种通迅方式：ADO,DAO,open2、数据集的建立方式：SQL方式，以及实体变量数据直接赋值到数据集方式。如：Dim TextRecordSet As ADODB.RecordsetSet 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 发表于 2008-3-28 20:14:00

收下学习一下

liusong0517 发表于 2008-4-1 22:36:00

楼主真牛

shajianlin 发表于 2008-4-18 11:19:00

没看懂！

askimol 发表于 2008-4-19 09:03:00

好好学习一下

页: [1]

明经CAD社区's Archiver

AutoCad+vb+excel+CopyFromRecordset