Dim db As dao.Database
Dim rs As dao.Recordset
Dim fd As dao.Field
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim cellCnt As Integer
' Open the destination Excel workbook.
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.add
Set xlSheet = xlBook.ActiveSheet
xlBook.PrintPreview
' Open the recordset.
Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\bmkq.mdb")
Set rs = db.OpenRecordset("SELECT ......")
' Title
xlSheet.Cells(1, 1).Value = "考勤汇总表"
' Tabel Heads
cellCnt = 1
For Each fd In rs.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(2, cellCnt).Value = fd.Name
xlSheet.Cells(2, cellCnt).Interior.ColorIndex = 33
xlSheet.Cells(2, cellCnt).Font.Bold = True
xlSheet.Cells(2, cellCnt).BorderAround xlContinuous
cellCnt = cellCnt + 1
End Select
Next
' This is all it takes to copy the contents
' of the recordset into the first worksheet
' of Book1.xls.
xlBook.Worksheets(1).Range("A3").CopyFromRecordset rs
xlApp.ActiveWindow.DisplayZeros = False
xlBook.Worksheets(1).Range("A3").Select
xlApp.Visible = True
' Clean up everything.
'xlBook.Save
'xlBook.Close False
'xlApp.Quit
rs.Close
db.Close
'Set xlBook = Nothing
'Set xlApp = Nothing
Set rs = Nothing
Set db = Nothing
exitsub: