CopyFromRecordset在AutoCADVBA中的应用

兰州人

CopyFromRecordset命令在ExcelVBA比较常用，将其移植到AutoCADVBA与EXCLE通讯中，工作效率比较高。
以下程序摘自http://support.microsoft.com/kb/246335/zh-cn原意虽是VB程序EXCEL的数据交换，但应用于AutoCADVBA中效果也是比较好的。

2. Private Sub CClick()
3.     Dim cnt As New ADODB.Connection
4.     Dim rst As New ADODB.Recordset
5.    
6.     Dim xlApp As Object
7.     Dim xlWb As Object
8.     Dim xlWs As Object
9.    
10.     Dim recArray As Variant
11.    
12.     Dim strDB As String
13.     Dim fldCount As Integer
14.     Dim recCount As Long
15.     Dim iCol As Integer
16.     Dim iRow As Integer
17.    
18.     ' Set the string to the path of your Northwind database
19.     strDB = "c:\program files\Microsoft office\office11\samples\Northwind.mdb"
20.   
21.     ' Open connection to the database
22.     cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
23.         "Data Source=" & strDB & ";"
24.         
25.     ' Open recordset based on Orders table
26.     rst.Open "Select * From 订单", cnt
27.    
28.     ' Create an instance of Excel and add a workbook
29.     Set xlApp = CreateObject("Excel.Application")
30.     Set xlWb = xlApp.Workbooks.Add
31.     Set xlWs = xlWb.Worksheets("Sheet1")
32.   
33.     ' Display Excel and give user control of Excel's lifetime
34.     xlApp.Visible = True
35.     xlApp.UserControl = True
36.    
37.     ' Copy field names to the first row of the worksheet
38.     fldCount = rst.Fields.Count
39.     For iCol = 1 To fldCount
40.         xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
41.     Next
42.         
43.     ' Check version of Excel
44.     If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
45.         'EXCEL 2000 or 2002: Use CopyFromRecordset
46.          
47.         ' Copy the recordset to the worksheet, starting in cell A2
48.         xlWs.Cells(2, 1).CopyFromRecordset rst
49.         'Note: CopyFromRecordset will fail if the recordset
50.         'contains an OLE object field or array data such
51.         'as hierarchical recordsets
52.         
53.     Else
54.         'EXCEL 97 or earlier: Use GetRows then copy array to Excel
55.    
56.         ' Copy recordset to an array
57.         recArray = rst.GetRows
58.         'Note: GetRows returns a 0-based array where the first
59.         'dimension contains fields and the second dimension
60.         'contains records. We will transpose this array so that
61.         'the first dimension contains records, allowing the
62.         'data to appears properly when copied to Excel
63.         
64.         ' Determine number of records
65.         recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
66.         
67.         ' Check the array for contents that are not valid when
68.         ' copying the array to an Excel worksheet
69.         For iCol = 0 To fldCount - 1
70.             For iRow = 0 To recCount - 1
71.                 ' Take care of Date fields
72.                 If IsDate(recArray(iCol, iRow)) Then
73.                     recArray(iCol, iRow) = Format(recArray(iCol, iRow))
74.                 ' Take care of OLE object fields or array fields
75.                 ElseIf IsArray(recArray(iCol, iRow)) Then
76.                     recArray(iCol, iRow) = "Array Field"
77.                 End If
78.             Next iRow 'next record
79.         Next iCol 'next field
80.             
81.         ' Transpose and Copy the array to the worksheet,
82.         ' starting in cell A2
83.         xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
84.             TransposeDim(recArray)
85.     End If
86.     ' Auto-fit the column widths and row heights
87.     xlApp.Selection.CurrentRegion.Columns.AutoFit
88.     xlApp.Selection.CurrentRegion.Rows.AutoFit
89.     ' Close ADO objects
90.     rst.Close
91.     cnt.Close
92.     Set rst = Nothing
93.     Set cnt = Nothing
94.    
95.     ' Release Excel references
96.     Set xlWs = Nothing
97.     Set xlWb = Nothing
98.     Set xlApp = Nothing
99. End Sub
101. Function TransposeDim(v As Variant) As Variant
102. ' Custom Function to Transpose a 0-based array (v)
103.    
104.     Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
105.     Dim tempArray As Variant
106.    
107.     Xupper = UBound(v, 2)
108.     Yupper = UBound(v, 1)
109.    
110.     ReDim tempArray(Xupper, Yupper)
111.     For X = 0 To Xupper
112.         For Y = 0 To Yupper
113.             tempArray(X, Y) = v(Y, X)
114.         Next Y
115.     Next X
116.    
117.     TransposeDim = tempArray
118. End Function

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 Sub Function 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

兰州人

2. Sub Ss()
3.   
4.   Dim xlSheet
5.   Set xlSheet = xlApp.sheets(2)
6.   
7.   
8.   Dim ColNum, RowNum, pp(0 To 2) As Double, RowColText
9.   Dim Ent As AcadEntity, tt As AcadText
10.   ColNum = Array(0, 10, 24, 44, 52, 61, 69, 77, 86, 94, 103, 111, 119, 128, 136, 145, 153, 161, 170, 178)
11.   ReDim Preserve ColNum(UBound(ColNum))
12.   
13.   RowNum = Array(0, 5, 11, 16, 22, 27, 32, 38, 43) ', 45, 48, 55)
14.   RowCount = UBound(RowNum)
15.   ReDim Preserve RowNum(UBound(RowNum))
16.   ReDim RowColText(UBound(RowNum) - 1, UBound(ColNum) - 1)
17. For Each Ent In ThisDrawing.ModelSpace
18.   Select Case Ent.ObjectName
19.     Case "AcDbText"
20.       Set tt = Ent
21.       
22.       For ii = 0 To UBound(ColNum) - 1
23.         If tt.InsertionPoint(0) > ColNum(ii) And tt.InsertionPoint(0) < ColNum(ii + 1) Then
24.           'Debug.Print ii + 1, tt.InsertionPoint(0)
25.           ColNumCount = ii
26.           Exit For
27.         End If
28.       Next ii
29.       
30.       For jj = 0 To UBound(RowNum)
31.         If tt.InsertionPoint(1) > RowNum(jj) And tt.InsertionPoint(1) < RowNum(jj + 1) Then
32.           'Debug.Print jj + 1, "-----", tt.InsertionPoint(1)
33.           RowNumCount = jj
34.           Exit For
35.         End If
36.       Next jj
37.       RowColText(RowNumCount, ColNumCount) = tt.TextString
38. '      xlSheet.Cells(RowNumCount + 1, ColNumCount + 1).Value = tt.TextString
39.   End Select
40.   
41. Next Ent
42. xlSheet.Range("A2").Resize(RowCount, 19).Value = RowColText
43.     Columns("A:S").Select
44.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
45.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
46.         :=xlPinYin, DataOption1:=xlSortNormal
47. Debug.Print
48. End Sub

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) < ColNum(ii + 1) Then           'Debug.Print ii + 1, tt.InsertionPoint(0)           ColNumCount = ii           Exit For         End If       Next ii              For jj = 0 To UBound(RowNum)         If tt.InsertionPoint(1) > 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

jsxygshh

占位，学习

xinhaichun

学习学习