Office中国论坛/Access中国论坛

标题: 关于窗体查询后导出为EXCEL表的问题! [打印本页]

作者: canghe168 时间: 2008-1-24 17:16
标题: 关于窗体查询后导出为EXCEL表的问题!
做了一个查询窗体,主窗体输入查询条件,子窗体(其数据源为数据查询)显示查询出的记录,有一个按纽"导出查询结果为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 时间: 2008-1-24 18:46
为了学习，向楼主谢谢，忠诚回复中。。。。。。。。。。。

作者: tmtony 时间: 2008-1-24 20:58
1.修改查询的sql内容, querydefs("查询").sql
2.读取数据集,逐个通过excel的VBA写入到excel中

作者: Grant 时间: 2008-1-24 21:06
给个现成的
把子窗体内容输出到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 时间: 2008-1-24 23:01
这里有个现成的例子供参考

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

作者: victor2005 时间: 2008-1-25 10:08
可以设定一个只输出想要字段的条件，然后移植到程序中，就可以了

作者: canghe168 时间: 2008-2-13 10:46
谢谢大家,1.25我们这里就受灾停电了