能不能查询结果导出到指定的excel

赌鬼

能不能查询结果导出到指定的excel

Henry D. Sy

1. '---------------------------------------------------------------------------------------
   
2. ' Procedure : QueryToExcel
   
3. ' DateTime  : 2008-12-2 00:02
   
4. ' Author      : Henry D. Sy
   
5. ' Purpose    : strQueryName 查询名（表名）
   
6. '                   xlsName 工作簿名
   
7. '                   strShtName 工作表名
   
8. '                   需要引用Microsoft Excel 11.0 Object Library
   
9. '---------------------------------------------------------------------------------------
   
10. '
    
11. Sub QueryToExcel(ByVal strQueryName As String, ByVal xlsName As String, ByVal _
    
12.                                                                         strShtName As String)
    
13. ' Send the Query results to Excel
    
14. ' for further analysis
    
15. 
    
16.     Dim rs As ADODB.Recordset
    
17.     Dim objXL As Excel.Application
    
18.     Dim objWs As Excel.Workbook
    
19.     Dim fld As ADODB.Field
    
20.     Dim intCol As Integer
    
21.     Dim intRow As Integer
    
22. 
    
23.     Set rs = New ADODB.Recordset
    
24. 
    
25.     ' Get the desired data into a recordset
    
26.     rs.Open strQueryName, CurrentProject.Connection
    
27. 
    
28.     ' Launch Excel
    
29.     Set objXL = New Excel.Application
    
30.     ' Open a  worksheet
    
31.     Set objWs = objXL.Workbooks.Open(CurrentProject.Path & "" & xlsName & _
    
32.                                      ".xls")
    
33.     objWs.Worksheets(strShtName).Activate
    
34. 
    
35.     ' Copy the data
    
36.     ' First the field names
    
37.     For intCol = 0 To rs.Fields.Count - 1
    
38.         Set fld = rs.Fields(intCol)
    
39.         objWs.Worksheets(strShtName).Cells(1, intCol + 1) = fld.Name
    
40.     Next intCol
    
41.     ' Now the actual data
    
42.     intRow = 2
    
43.     Do Until rs.EOF
    
44.         For intCol = 0 To rs.Fields.Count - 1
    
45.             objWs.Worksheets(strShtName).Cells(intRow, intCol + 1) = _
    
46.             rs.Fields(intCol).Value
    
47.         Next intCol
    
48.         rs.MoveNext
    
49.         intRow = intRow + 1
    
50.     Loop
    
51. 
    
52.     ' Make the worksheet visible
    
53.     objXL.Visible = True
    
54.     rs.Close
    
55.     Set rs = Nothing
    
56. End Sub
    

复制代码

1. Private Sub Command0_Click()
   
2.     QueryToExcel "要导出的查询（表）名", "工作簿名", "工作表名"
   
3. End Sub

复制代码

renyucai1963

gxy1000

以前有这种实例，现在找不了