'---------------------------------------------------------------------------------------
' Procedure : QueryToExcel
' DateTime : 2008-12-2 00:02
' Author : Henry D. Sy
' Purpose : strQueryName 查询名（表名）
' xlsName 工作簿名
' strShtName 工作表名
' 需要引用Microsoft Excel 11.0 Object Library
'---------------------------------------------------------------------------------------
'
Sub QueryToExcel(ByVal strQueryName As String, ByVal xlsName As String, ByVal _
strShtName As String)
' Send the Query results to Excel
' for further analysis
Dim rs As ADODB.Recordset
Dim objXL As Excel.Application
Dim objWs As Excel.Workbook
Dim fld As ADODB.Field
Dim intCol As Integer
Dim intRow As Integer
Set rs = New ADODB.Recordset
' Get the desired data into a recordset
rs.Open strQueryName, CurrentProject.Connection
' Launch Excel
Set objXL = New Excel.Application
' Open a worksheet
Set objWs = objXL.Workbooks.Open(CurrentProject.Path & "\" & xlsName & _
".xlsx")
objWs.Worksheets(strShtName).Activate
' Copy the data
' First the field names
For intCol = 0 To rs.Fields.Count - 1
Set fld = rs.Fields(intCol)
objWs.Worksheets(strShtName).Cells(1, intCol + 1) = fld.Name
Next intCol
' Now the actual data
intRow = 2
Do Until rs.EOF
For intCol = 0 To rs.Fields.Count - 1
objWs.Worksheets(strShtName).Cells(intRow, intCol + 1) = _
rs.Fields(intCol).Value
Next intCol
rs.MoveNext
intRow = intRow + 1
Loop
' Make the worksheet visible
objXL.Visible = True
rs.Close
Set rs = Nothing
End Sub
Private Sub 导出_CRM_Click()
QueryToExcel "统计表", "CRM", "统计"
QueryToExcel "实施清单", "CRM", "清单"
End Sub