CopyFromRecordset在AutoCADVBA中的应用

Private Sub CClick()
    Dim cnt As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    
    Dim recArray As Variant
    
    Dim strDB As String
    Dim fldCount As Integer
    Dim recCount As Long
    Dim iCol As Integer
    Dim iRow As Integer
    
    ' Set the string to the path of your Northwind database
    strDB = "c:\program files\Microsoft office\office11\samples\Northwind.mdb"
  
    ' Open connection to the database
    cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & strDB & ";"
        
    ' Open recordset based on Orders table
    rst.Open "Select * From 订单", cnt
    
    ' Create an instance of Excel and add a workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Sheet1")
  
    ' Display Excel and give user control of Excel's lifetime
    xlApp.Visible = True
    xlApp.UserControl = True
    
    ' Copy field names to the first row of the worksheet
    fldCount = rst.Fields.Count
    For iCol = 1 To fldCount
        xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
    Next
        
    ' Check version of Excel
    If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
        'EXCEL 2000 or 2002: Use CopyFromRecordset
         
        ' Copy the recordset to the worksheet, starting in cell A2
        xlWs.Cells(2, 1).CopyFromRecordset rst
        'Note: CopyFromRecordset will fail if the recordset
        'contains an OLE object field or array data such
        'as hierarchical recordsets
        
    Else
        'EXCEL 97 or earlier: Use GetRows then copy array to Excel
    
        ' Copy recordset to an array
        recArray = rst.GetRows
        'Note: GetRows returns a 0-based array where the first
        'dimension contains fields and the second dimension
        'contains records. We will transpose this array so that
        'the first dimension contains records, allowing the
        'data to appears properly when copied to Excel
        
        ' Determine number of records
        recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
        
        ' Check the array for contents that are not valid when
        ' copying the array to an Excel worksheet
        For iCol = 0 To fldCount - 1
            For iRow = 0 To recCount - 1
                ' Take care of Date fields
                If IsDate(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = Format(recArray(iCol, iRow))
                ' Take care of OLE object fields or array fields
                ElseIf IsArray(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = "Array Field"
                End If
            Next iRow 'next record
        Next iCol 'next field
            
        ' Transpose and Copy the array to the worksheet,
        ' starting in cell A2
        xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
            TransposeDim(recArray)
    End If
    ' Auto-fit the column widths and row heights
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit
    ' Close ADO objects
    rst.Close
    cnt.Close
    Set rst = Nothing
    Set cnt = Nothing
    
    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
End SubFunction TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)
    
    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant
    
    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)
    
    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X
    
    TransposeDim = tempArray
End Function

Sub Ss()
  
  Dim xlSheet
  Set xlSheet = xlApp.sheets(2)
  
  
  Dim ColNum, RowNum, pp(0 To 2) As Double, RowColText
  Dim Ent As AcadEntity, tt As AcadText
  ColNum = Array(0, 10, 24, 44, 52, 61, 69, 77, 86, 94, 103, 111, 119, 128, 136, 145, 153, 161, 170, 178)
  ReDim Preserve ColNum(UBound(ColNum))
  
  RowNum = Array(0, 5, 11, 16, 22, 27, 32, 38, 43) ', 45, 48, 55)
  RowCount = UBound(RowNum)
  ReDim Preserve RowNum(UBound(RowNum))
  ReDim RowColText(UBound(RowNum) - 1, UBound(ColNum) - 1)
For Each Ent In ThisDrawing.ModelSpace
  Select Case Ent.ObjectName
    Case "AcDbText"
      Set tt = Ent
      
      For ii = 0 To UBound(ColNum) - 1
        If tt.InsertionPoint(0) > ColNum(ii) And tt.InsertionPoint(0)  RowNum(jj) And tt.InsertionPoint(1) < RowNum(jj + 1) Then
          'Debug.Print jj + 1, "-----", tt.InsertionPoint(1)
          RowNumCount = jj
          Exit For
        End If
      Next jj
      RowColText(RowNumCount, ColNumCount) = tt.TextString
'      xlSheet.Cells(RowNumCount + 1, ColNumCount + 1).Value = tt.TextString
  End Select
  
Next Ent
xlSheet.Range("A2").Resize(RowCount, 19).Value = RowColText
    Columns("A:S").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
Debug.Print
End Sub