设DataGrid的dadasource为rs dim excelapp as new excel.application excelapp.workbooks.add excelapp.visibla=true rs.movefirst dim i,r do while rs.eof=false excelapp.cells(r,i)=rs.fields(0) .... rs.movenext loop
昨天看見泰山以前寫的一個exp。 一下﹐等下找給你
他應該是98下完成的﹐2K下測試通過﹐但是會出現一點問題﹐偶還沒有來得及改。 需要三個表﹕畢業學生﹐在校學生﹐退學學生﹐ 表中字段"班級,姓名,工作單位" Option Explicit '聲明API函數Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long'定義變量Dim Cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.RecordsetDim StrSQL As StringDim TabName As StringDim Selection As StringPrivate Sub Command1_Click()'設置第一個數據源的查詢條件TabName = "畢業學生"Selection = "班級,姓名,工作單位"'獲取數據ReqDataEnd SubPrivate Sub Command2_Click()'設置第二個數據源的查詢條件TabName = "在校學生"Selection = "*"'獲取數據ReqDataEnd SubPrivate Sub Command3_Click()'設置第三個數據源的查詢條件TabName = "退學學生"Selection = "班級,姓名,性別"'獲取數據ReqDataEnd SubPrivate Sub Command4_Click()'如果EXCEL文件已經打開,需要先關閉它.Dim lpClassName As StringDim lpCaption As StringDim Handle As LonglpClassName = "XLMAIN"lpCaption = "Microsoft Excel - MyExcel.xls"Handle = FindWindow(lpClassName$, lpCaption$)If Handle <> 0 ThenMsgBox "請先關閉EXCEL文件!", vbOKOnly + vbInformation, "不能對已經打開的文件進行寫操作!"Exit SubEnd If'檢查EXCEL文件是否存在,如果存在則?除 If Dir(App.Path & "\MyExcel.xls") <> "" Then Kill App.Path & "\MyExcel.xls"'進行數據轉換Dim dbs As Database'打開數據庫Set dbs = OpenDatabase(App.Path & "\db1.mdb") '把數據導入EXCELdbs.Execute "SELECT " & Selection & " INTO [Excel 8.0;DATABASE=" & App.Path & "\MyExcel.xls].[WorkSheet1] FROM " & TabName'關閉數據庫對象dbs.Close'釋放數據庫對象Set dbs = Nothing'調用EXCEL打開?生的EXCEL表格Shell "C:\Program Files\Microsoft Office\Office10\EXCEL.EXE " & App.Path & "\MyExcel.xls", vbMaximizedFocusEnd SubPrivate Sub ReqData()'設置查詢語句StrSQL = "SELECT " & Selection & " FROM " & TabName'如果數據庫已打開的則先關閉,防止出錯If Cnn1.ConnectionString <> "" Then Cnn1.Close'打開數據庫Cnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & App.Path & "\db1.mdb;" Cnn1.CursorLocation = adUseClient'設置記錄集的打開方式和鎖的機制等With rst1 .CursorType = adOpenKeyset .LockType = adLockOptimistic .Open StrSQL, Cnn1, , , adCmdTextEnd With'?DataGrid1設置數據源Set DataGrid1.DataSource = rst1DataGrid1.Refresh'?DataGrid1設置標題,?顯示記錄數DataGrid1.Caption = "表[" & TabName & "]共" & rst1.RecordCount & "條記錄"End SubPrivate Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)'?DataGrid1設置標題,?顯示記錄數,用此事件是防止操作員?除記錄後記錄數發生變化DataGrid1.Caption = "表[" & TabName & "]共" & rst1.RecordCount & "條記錄"End Sub
Private Sub cmd_excel_Click() Load For_excel_option Set For_excel_option.FormName = Me Call For_excel_option.cmd_ok_Click End Sub Public Sub cmd_ok_Click() Me.MousePointer = 11 ''先判断是哪个窗体，然后判断是全部还是当前页 If Opt_now.Value = True Then Me.Hide cmd_excel FormName Unload Me Else If ProString = "" Then Me.Hide FormName.Ado_main.RecordSource = SqlString FormName.Ado_main.Refresh FormName.DataGrid.Refresh cmd_excel FormName FormName.Ado_main.RecordSource = SqlString FormName.Ado_main.Refresh FormName.DataGrid.Refresh Unload Me Else Me.Hide FormName.Ado_main.RecordSource = ProString & ",@rowcount=0" FormName.Ado_main.Refresh FormName.DataGrid.Refresh cmd_excel FormName FormName.Ado_main.RecordSource = ProString FormName.Ado_main.Refresh FormName.DataGrid.Refresh Unload Me End If End If End Sub ''导出excel的过程 Sub cmd_excel(frm As Form) ''excel的对象定义 Dim MyApp As Excel.Application Dim MyBook As Excel.Workbook Dim MySheet As Excel.Worksheet Dim msgString As String Dim NowCol As Integer ''当前行 Set MyApp = CreateObject("Excel.Application") MyApp.Visible = False Set MyBook = MyApp.Workbooks.Add() Set MySheet = MyBook.Worksheets(1) frm.Ado_main.Recordset.MoveFirst''调用和初始化进度条 Frm_prg.Excel_Prg.Max = frm.Ado_main.Recordset.RecordCount Frm_prg.Show Frm_prg.MousePointer = 11j = 1 Do Until frm.Ado_main.Recordset.EOF If j = 1 Then
MySheet.Cells(j, 1) = "记录索引" MySheet.Cells(j, 2) = "c4局号" MySheet.Cells(j, 3) = "c4名称" MySheet.Cells(j, 4) = "c5局号" MySheet.Cells(j, 5) = "c5名称" MySheet.Cells(j, 6) = "人员名称" MySheet.Cells(j, 7) = "开门时间" MySheet.Cells(j, 8) = "关门时间" MySheet.Cells(j, 9) = "开门信息" 'add by hmj 03/12/25 for rj j = j + 1 frm.Ado_main.Recordset.MoveFirst Else On Error Resume Next NowCol = 0 '第一列 For i = 1 To frm.Ado_main.Recordset.Fields.Count NowCol = NowCol + 1 Select Case frm.Name Case "Frm_activealm" If i = 6 Then i = i + 1 If i = 8 Then i = i + 1 Case "frm_todayalm" If i = 7 Then i = i + 1 If i = 9 Then i = i + 1 Case "frm_hisenv" If i = 9 Then i = i + 1 Case "Frm_dispatch" If i = 8 Then i = i + 1 Case "frm_hisalm" If i = 9 Then i = i + 1 Case "Frm_doorhisalm" If i = 9 Then i = i + 1 Case "frm_test" If i = 7 Then i = i + 1 Case "Frm_event" If i = 6 Then i = i + 1
End Select
msgString = frm.Ado_main.Recordset.Fields(i - 1) MySheet.Cells(j, NowCol) = msgString msgString = "" Next i frm.Ado_main.Recordset.MoveNext ''对进度条的进度控制 On Error Resume Next Frm_prg.Excel_Prg.Value = j If Frm_prg.ESCCancle = False Then Exit Sub End If If j >= frm.Ado_main.Recordset.RecordCount Then Unload Frm_prg SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 End If j = j + 1 End If Loop ''保存文件 On Error Resume Next MyApp.Visible = TrueSet MyApp = Nothing Frm_prg.MousePointer = 0 End Sub
dim excelapp as new excel.application
excelapp.workbooks.add
excelapp.visibla=true
rs.movefirst
dim i,r
do while rs.eof=false
excelapp.cells(r,i)=rs.fields(0)
....
rs.movenext
loop
一下﹐等下找給你
需要三個表﹕畢業學生﹐在校學生﹐退學學生﹐
表中字段"班級,姓名,工作單位"
Option Explicit
'聲明API函數Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long'定義變量Dim Cnn1 As New ADODB.ConnectionDim rst1 As New ADODB.RecordsetDim StrSQL As StringDim TabName As StringDim Selection As StringPrivate Sub Command1_Click()'設置第一個數據源的查詢條件TabName = "畢業學生"Selection = "班級,姓名,工作單位"'獲取數據ReqDataEnd SubPrivate Sub Command2_Click()'設置第二個數據源的查詢條件TabName = "在校學生"Selection = "*"'獲取數據ReqDataEnd SubPrivate Sub Command3_Click()'設置第三個數據源的查詢條件TabName = "退學學生"Selection = "班級,姓名,性別"'獲取數據ReqDataEnd SubPrivate Sub Command4_Click()'如果EXCEL文件已經打開,需要先關閉它.Dim lpClassName As StringDim lpCaption As StringDim Handle As LonglpClassName = "XLMAIN"lpCaption = "Microsoft Excel - MyExcel.xls"Handle = FindWindow(lpClassName$, lpCaption$)If Handle <> 0 ThenMsgBox "請先關閉EXCEL文件!", vbOKOnly + vbInformation, "不能對已經打開的文件進行寫操作!"Exit SubEnd If'檢查EXCEL文件是否存在,如果存在則?除 If Dir(App.Path & "\MyExcel.xls") <> "" Then Kill App.Path & "\MyExcel.xls"'進行數據轉換Dim dbs As Database'打開數據庫Set dbs = OpenDatabase(App.Path & "\db1.mdb") '把數據導入EXCELdbs.Execute "SELECT " & Selection & " INTO [Excel 8.0;DATABASE=" & App.Path & "\MyExcel.xls].[WorkSheet1] FROM " & TabName'關閉數據庫對象dbs.Close'釋放數據庫對象Set dbs = Nothing'調用EXCEL打開?生的EXCEL表格Shell "C:\Program Files\Microsoft Office\Office10\EXCEL.EXE " & App.Path & "\MyExcel.xls", vbMaximizedFocusEnd SubPrivate Sub ReqData()'設置查詢語句StrSQL = "SELECT " & Selection & " FROM " & TabName'如果數據庫已打開的則先關閉,防止出錯If Cnn1.ConnectionString <> "" Then Cnn1.Close'打開數據庫Cnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & App.Path & "\db1.mdb;"
Cnn1.CursorLocation = adUseClient'設置記錄集的打開方式和鎖的機制等With rst1 .CursorType = adOpenKeyset .LockType = adLockOptimistic .Open StrSQL, Cnn1, , , adCmdTextEnd With'?DataGrid1設置數據源Set DataGrid1.DataSource = rst1DataGrid1.Refresh'?DataGrid1設置標題,?顯示記錄數DataGrid1.Caption = "表[" & TabName & "]共" & rst1.RecordCount & "條記錄"End SubPrivate Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)'?DataGrid1設置標題,?顯示記錄數,用此事件是防止操作員?除記錄後記錄數發生變化DataGrid1.Caption = "表[" & TabName & "]共" & rst1.RecordCount & "條記錄"End Sub
Load For_excel_option
Set For_excel_option.FormName = Me
Call For_excel_option.cmd_ok_Click
End Sub
Public Sub cmd_ok_Click()
Me.MousePointer = 11
''先判断是哪个窗体，然后判断是全部还是当前页
If Opt_now.Value = True Then
Me.Hide
cmd_excel FormName
Unload Me
Else
If ProString = "" Then
Me.Hide
FormName.Ado_main.RecordSource = SqlString
FormName.Ado_main.Refresh
FormName.DataGrid.Refresh
cmd_excel FormName
FormName.Ado_main.RecordSource = SqlString
FormName.Ado_main.Refresh
FormName.DataGrid.Refresh
Unload Me
Else
Me.Hide
FormName.Ado_main.RecordSource = ProString & ",@rowcount=0"
FormName.Ado_main.Refresh
FormName.DataGrid.Refresh
cmd_excel FormName
FormName.Ado_main.RecordSource = ProString
FormName.Ado_main.Refresh
FormName.DataGrid.Refresh
Unload Me
End If
End If
End Sub
''导出excel的过程
Sub cmd_excel(frm As Form)
''excel的对象定义
Dim MyApp As Excel.Application
Dim MyBook As Excel.Workbook
Dim MySheet As Excel.Worksheet
Dim msgString As String
Dim NowCol As Integer ''当前行
Set MyApp = CreateObject("Excel.Application")
MyApp.Visible = False
Set MyBook = MyApp.Workbooks.Add()
Set MySheet = MyBook.Worksheets(1)
frm.Ado_main.Recordset.MoveFirst''调用和初始化进度条
Frm_prg.Excel_Prg.Max = frm.Ado_main.Recordset.RecordCount
Frm_prg.Show
Frm_prg.MousePointer = 11j = 1
Do Until frm.Ado_main.Recordset.EOF
If j = 1 Then
MySheet.Cells(j, 1) = "记录索引"
MySheet.Cells(j, 2) = "c4局号"
MySheet.Cells(j, 3) = "c4名称"
MySheet.Cells(j, 4) = "c5局号"
MySheet.Cells(j, 5) = "c5名称"
MySheet.Cells(j, 6) = "人员名称"
MySheet.Cells(j, 7) = "开门时间"
MySheet.Cells(j, 8) = "关门时间"
MySheet.Cells(j, 9) = "开门信息"
'add by hmj 03/12/25 for rj
j = j + 1
frm.Ado_main.Recordset.MoveFirst
Else
On Error Resume Next
NowCol = 0 '第一列
For i = 1 To frm.Ado_main.Recordset.Fields.Count
NowCol = NowCol + 1
Select Case frm.Name
Case "Frm_activealm"
If i = 6 Then i = i + 1
If i = 8 Then i = i + 1 Case "frm_todayalm"
If i = 7 Then i = i + 1
If i = 9 Then i = i + 1
Case "frm_hisenv"
If i = 9 Then i = i + 1
Case "Frm_dispatch"
If i = 8 Then i = i + 1
Case "frm_hisalm"
If i = 9 Then i = i + 1
Case "Frm_doorhisalm"
If i = 9 Then i = i + 1
Case "frm_test"
If i = 7 Then i = i + 1
Case "Frm_event"
If i = 6 Then i = i + 1
End Select
msgString = frm.Ado_main.Recordset.Fields(i - 1)
MySheet.Cells(j, NowCol) = msgString
msgString = ""
Next i
frm.Ado_main.Recordset.MoveNext
''对进度条的进度控制
On Error Resume Next
Frm_prg.Excel_Prg.Value = j
If Frm_prg.ESCCancle = False Then
Exit Sub
End If
If j >= frm.Ado_main.Recordset.RecordCount Then
Unload Frm_prg
SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
End If
j = j + 1
End If
Loop
''保存文件
On Error Resume Next
MyApp.Visible = TrueSet MyApp = Nothing
Frm_prg.MousePointer = 0
End Sub