建个模块,放入下面代码:
Public Function SJDC(RSrecord As ADODB.Recordset)
On Error GoTo Err1
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
' 假设Rs_Data 是你的记录集
With RSrecord
If .RecordCount < 1 Then
MsgBox "没有可导出的记录!", vbInformation + vbOKOnly, "提示"
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(RSrecord, xlSheet.Range("a1"))
' .PageSetup.PaperSize = xlPaperA4 '
' .PageSetup.PrintGridlines = True
End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
Set Rs_Data = Nothing
Exit Function
Err1: MsgBox Error & ",Excel 2000未安装!"
End Function
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpszValueName As String, _
ByVal lpdwRes As Long, _
ByRef lpdwType As Long, _
ByVal lpDataBuff As String, _
ByRef nSize As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Function GetVBPath() As String
Dim lngLength As Long
Dim lngReturnCode As Long
Dim lngType As Long
Dim lngVBKey As Long
Dim strPath As String
Dim strVBEntry As String
Dim strX As String * 255
Dim fso As New Scripting.FileSystemObject
Dim strFileName As String
' 若無檔案名稱,則使用暫存檔方式產生檔名。
If txtField(0).Text = "" Then
strFileName = App.Path & "\" & fso.GetBaseName(fso.GetTempName())
Else
strFileName = txtField(0).Text
End If
'=========================================================================================
' 目 的: 複製記錄至試算表(Excel)
' 參 數: ADODB.Recordset : objRst 資料錄物件。
' String : strFilename 檔案名稱。
' XlFileFormat : FileFormat 檔案格式。
' Boolean : blnHeaders 是否有表頭。
'
' 日 期 By COMMENT
' ---------- ---- -------
' 2000/12/02 Marko Hernandez 建立
' 2001/03/20 Spencer Yang 修改錯誤
'=========================================================================================
Sub SaveAsExcel(ByVal objRst As ADODB.Recordset, _
ByVal strFileName As String, _
Optional FileFormat As XlFileFormat = xlWorkbookNormal, _
Optional blnHeaders As Boolean = True)
Dim intRowCnt As Integer ' 列之計數器。
Dim intColCnt As Integer ' 欄之計數器。
Dim objExcel As Excel.Application
Dim objFld As Field
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim strFileExtensionType As String ' 延伸檔名。
On Error GoTo SaveAsExcel_EH
Screen.MousePointer = vbHourglass
'------------------------------------------------
' A0 Excel 相關設定作業。
'------------------------------------------------
Set objExcel = New Excel.Application
' 不讓使用者操作。
objExcel.Interactive = False
' 背後作業。
If objExcel.Visible = False Then
objExcel.Visible = True
End If
' 視窗最大化。
objExcel.WindowState = xlMaximized
' 設定 Wokkbook 物件。
Set objWorkbook = objExcel.Workbooks.Add
' 設定 Worksheet 物件,指向 Sheet 1。
Set objWorksheet = objWorkbook.Worksheets.Add
'------------------------------------------------
' A1 Excel 表頭部份相關設定作業。
'------------------------------------------------
If blnHeaders Then
intColCnt = 1
For Each objFld In objRst.Fields
Select Case objFld.Type
' 下述資料型態則予以略過。
Case adGUID, adLongVarBinary, adLongVarWChar
当然可以
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const WM_QUIT = &H12
Dim Cnn1 As New ADODB.Connection
Dim rst1 As New ADODB.Recordset
Dim strCnn As String
Dim StrSQL As String
Private Sub Command1_Click()
Dim lpClassName As String
Dim lpCaption As String
Dim Handle As Long
Dim iReturn As Integer
lpClassName = "XLMAIN"
lpCaption = "Microsoft Excel - MyExcel.xls"
Handle = FindWindow(lpClassName$, lpCaption$)
If Handle <> 0 Then
iReturn = PostMessage(Handle, WM_QUIT, 0, 0&)
End If
'把选中的记录写到EXCEL
If DataGrid1.Col = 1 Then
Dim dbs As Database
Set dbs = OpenDatabase(App.Path & "\db2.mdb")
'如果worksheet1已经存在,改为worksheet2或者其他
dbs.Execute "SELECT * INTO [Excel 8.0;DATABASE=" & App.Path & "\MyExcel.xls].[WorkSheet1] " _
& "FROM [在校学生] WHERE " & DataGrid1.Columns(DataGrid1.Col).Caption & "='" & Trim(DataGrid1.Text) & "'"
dbs.Close
Set dbs = Nothing
Shell "C:\Program Files\Microsoft Office\Office\EXCEL.EXE " & App.Path & "\MyExcel.xls", vbMaximizedFocus
Else
MsgBox "没选中姓名"
End If
End Sub
Private Sub Form_Load()
StrSQL = "SELECT 班级,姓名,性别 FROM 在校学生"
'如果数据库已打开的则先关闭,防止出错
If Cnn1.ConnectionString <> "" Then Cnn1.Close
'打开数据库
'Cnn1.Open
strCnn = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & App.Path & "\db2.mdb;"
'设置记录集的打开方式和锁的机制等
With rst1
.ActiveConnection = strCnn
.ActiveConnection = strCnn
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.Source = StrSQL
.Open
End With
'为DataGrid1设置数据源
Set DataGrid1.DataSource = rst1
DataGrid1.Refresh
'为DataGrid1设置标题,并显示记录数
DataGrid1.Caption = "表[在校学生]共" & rst1.RecordCount & "条记录"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim lpClassName As String
Dim lpCaption As String
Dim Handle As Long
Dim iReturn As Integer
lpClassName = "XLMAIN"
lpCaption = "Microsoft Excel - MyExcel.xls"
Handle = FindWindow(lpClassName$, lpCaption$)
If Handle <> 0 Then
iReturn = PostMessage(Handle, WM_QUIT, 0, 0&)
End If