Office中国论坛/Access中国论坛

标题: 这段代码换成ADO如何写 [打印本页]

---

作者: bach    时间: 2008-8-1 02:24
标题: 这段代码换成ADO如何写
还在用97所以,还要用ADO写,谁能改一下.
Private Sub cmd导出_Click()
On Error GoTo Err_cmd导出_Click
'刘小军(Alex) 2003-5-22
'这里将使用DAO来改变查询的SQL语句，必须先在“工具”→“引用”中选择
'Microsoft DAO 3.6 Object Library.
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

    Dim qdf As DAO.QueryDef 'qdf被定义为一个查询定义对象
    Dim strWhere, strSQL As String
   
    strWhere = Me.存书查询子窗体.Form.Filter
    If strWhere = "" Then
        '没有条件
        strSQL = "SELECT * FROM [存书查询]"
    Else
        '有条件
        strSQL = "SELECT * FROM [存书查询] WHERE " & strWhere
    End If
   
    Set qdf = CurrentDb.QueryDefs("查询结果")
    qdf.SQL = strSQL
    qdf.Close
   
    Set qdf = Nothing
   
    DoCmd.OutputTo acOutputQuery, "查询结果", acFormatXLS, , True

   
Exit_cmd导出_Click:
    Exit Sub

Err_cmd导出_Click:
    MsgBox Err.Description
    Resume Exit_cmd导出_Click
   
End Sub

---

作者: Grant    时间: 2008-8-1 09:18
方法一.
把子窗体的内容复制到EXCEL（子窗体可以是任意形式，如：连接窗体，数据表窗体）
Sub 把子窗体的内容复制到EXCEL()
   
    Me.Child28.SetFocus    '把焦点移动子窗体上  Child28要操作的子窗体的名称
    DoCmd.RunCommand acCmdSelectAllRecords
    DoCmd.RunCommand acCmdCopy
  
    Dim obj As Object
    Set obj = CreateObject("excel.application")

    obj.Workbooks.Add
    obj.Visible = True

    SendKeys "^v"
End Sub

方法二.
把子窗体内容输出到EXCEL中
On Error GoTo errit

Dim oExcel As Object
Dim oBook As Object
Dim I As Integer
   
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add()
   
   Me.子窗体.Form.Recordset.MoveFirst
   
   For I = 0 To Me.子窗体.Form.Recordset.Fields.Count - 1
      oBook.Worksheets(1).Cells(1, I + 1).Value = Me.子窗体.Form.Recordset.Fields(I).Name
   Next

   oBook.Worksheets(1).Range("A2").CopyFromRecordset Me.子窗体.Form.Recordset
   oBook.SaveAs ("d:\Test.xls")
   MsgBox "导出成功"

errexit:
   oBook.Close False
   oExcel.Quit
   Set oBook = Nothing
   Set oExcel = Nothing
   Exit Sub

errit:
   MsgBox "错误号为" & Err.Number & " 错误说明：" & Err.Description
   Resume errexit


************************
很好,其实改为通用函数岂不更好?

Public Sub rs2xls(rs As Object)
'将子窗体记录复制到XLS中
On Error GoTo errit
'set rs = Me.子窗体.Form.Recordset
Dim oExcel As Object
Dim oBook As Object
Dim I As Integer
   
   Set oExcel = CreateObject("Excel.Application")
   Set oBook = oExcel.Workbooks.Add()
   
   rs.MoveFirst
   
   For I = 0 To rs.Fields.Count - 1
      oBook.Worksheets(1).Cells(1, I + 1).Value = rs.Fields(I).Name
   Next

   oBook.Worksheets(1).Range("A2").CopyFromRecordset rs
   oBook.SaveAs ("C:\Book1.xls")
   MsgBox "导出成功"
'打開文件時用到.

'ShellExecute Application.hWndAccessApp, "Open", "d:\Test.xls", "", "d:\", SW_NORMAL

errexit:
   oBook.Close False
   oExcel.Quit
   Set oBook = Nothing
   Set oExcel = Nothing
   Exit Sub

errit:
   MsgBox "错误号为" & Err.Number & " 错误说明：" & Err.Description
   Resume errexit

End Sub

然后在窗体中调用即可:


Private Sub Command1_Click()
rs2xls subfrm.Form.Recordset   '子窗体: subfrm
End Sub


******************************************
Public Sub OutputSubForm(frmMainForm As Form, frmSubFormName As String)
'*****************************************************
'使用示例：OutputSubForm Me, Me.订单子窗体.Name
'http://www.accfans.net 李寻欢
'2005-08-16
'******************************************************
Dim strSql As String
Dim strRecordSource As String
Dim strLinkChildfields As String
Dim strLinkMasterFields As String
Dim strFilter As String
Dim blnFilterOn As Boolean
Dim strLinkSQL As String
Dim Rs As Recordset
Dim Qd As QueryDef

On Error GoTo Outputerr:
Set Rs = frmMainForm.Controls(frmSubFormName).Form.RecordsetClone
Set Qd = CurrentDb.CreateQueryDef("qryTemp")

strRecordSource = frmMainForm.Controls(frmSubFormName).Form.RecordSource
strLinkChildfields = frmMainForm.Controls(frmSubFormName).LinkChildFields
strLinkMasterFields = frmMainForm.Controls(frmSubFormName).LinkMasterFields
strFilter = frmMainForm.Controls(frmSubFormName).Form.Filter
blnFilterOn = frmMainForm.Controls(frmSubFormName).Form.FilterOn

If strLinkChildfields <> "" Then
    Select Case Rs.Fields(strLinkChildfields)
    Case dbChar
        strLinkSQL = strLinkChildfields & "='" & frmMainForm.Controls(strLinkMasterFields) & "'"
    Case Else
        strLinkSQL = strLinkChildfields & "=" & frmMainForm.Controls(strLinkMasterFields)
    End Select
End If

If blnFilterOn = True Then
    If strLinkSQL <> "" Then
        strLinkSQL = strLinkSQL & " and " & strFilter
    Else
        strLinkSQL = strFilter
    End If
End If

If InStr(strRecordSource, "Select ") > 0 Then
    strSql = Left(strRecordSource, Len(strRecordSource) - 2)
Else
    strSql = "Select * From " & strRecordSource
End If

If InStr(strRecordSource, " where ") > 0 Then
    If strLinkSQL <> "" Then
        strSql = strSql & " and " & strLinkSQL
    End If
Else
    If strLinkSQL <> "" Then
        strSql = strSql & " where " & strLinkSQL
    End If
End If
Qd.SQL = strSql
DoCmd.OutputTo acOutputQuery, "qryTemp"
DoCmd.DeleteObject acQuery, "qryTemp"
Rs.Close
Set Rs = Nothing

Exit Sub

Outputerr:
    Rs.Close
    Set Rs = Nothing
    If IsNull(Dlookup("[Name]", "MSysObjects", "[Name] = 'qryTemp'")) = False Then
         DoCmd.DeleteObject acQuery, "qryTemp"
    End If
    MsgBox Err.Description
End Sub

调用方法：
Private Sub Command5_Click()
OutputSubForm Me, Me.表1子窗体.Name
End Sub

---

作者: bach    时间: 2008-8-1 15:16
[:33] [:33]

---

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)

Powered by Discuz! X3.3