关于窗体查询后导出为EXCEL表的问题!

canghe168

做了一个查询窗体,主窗体输入查询条件,子窗体(其数据源为数据查询)显示查询出的记录,有一个按纽"导出查询结果为EXCEL",按纽代码如下

Private Sub cmd导出_Click()
On Error GoTo Err_cmd导出_Click

Dim qdf As DAO.QueryDef
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, "查询结果EXCEL", acFormatXLS, , True
   
Exit_cmd导出_Click:
    Exit Sub
Err_cmd导出_Click:
    MsgBox Err.Description
    Resume Exit_cmd导出_Click
   
End Sub

我现在要问的是,怎么修改上面的代码,始其导出子窗体查询结果为EXCEL表的时候,可以选择字段导出,(比如查询结果有50条记录,5个字段,而只导出有2个字段的50条记录)
请大家帮忙实现,谢谢拉!

[ 本帖最后由 canghe168 于 2008-1-24 17:17 编辑 ]

dpdm168

为了学习，向楼主谢谢，忠诚回复中。。。。。。。。。。。

tmtony

1.修改查询的sql内容,  querydefs("查询").sql
2.读取数据集,逐个通过excel的VBA写入到excel中

Grant

给个现成的
把子窗体内容输出到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

rjacky

这里有个现成的例子供参考

http://www.office-cn.net/forum.p ... p;extra=&page=1

victor2005

可以设定一个只输出想要字段的条件，然后移植到程序中，就可以了

canghe168

谢谢大家,1.25我们这里就受灾停电了 今天才上来看到,有这么多好的回复
rjacky的例子就是我想要的,但是我的字段很多,有10多个,如果输出的时候一个一个输字段条件,很麻烦,能不能改成选择的,比如用复选框??谢谢大家继续支持!

canghe168

我争取做个附件传上来,大家帮我看看!

天涯路

我也想看看，也想要这个功能

风清九剑扬

学习学习牛人的程序