AutoCad+vb+excel+CopyFromRecordset

[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

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