Office中国论坛/Access中国论坛

标题: [分享]导出数据表型子窗体内容到Excel [打印本页]

作者: 海狸先生 时间: 2005-8-16 03:19
标题: [分享]导出数据表型子窗体内容到Excel
看到网上的一些导出例子是用　复制拷贝　的方法　把子窗体内容导出，在记录多的时候就很慢

下面是我结合从网上找到的一些资料和查自带帮助　写下的，希望给大家带来方便

Private Sub ImportToExcel()

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")

oBook.Close False

oExcel.Quit

Set oBook = Nothing

Set oExcel = Nothing

End Sub

[此贴子已经被作者于2005-8-15 19:23:51编辑过]

作者: 爱情插班生 时间: 2005-8-16 03:30
不用客气！[em01][em01][em01]

作者: 海狸先生 时间: 2005-8-16 03:49
晕

作者: wu8313 时间: 2005-8-16 04:39
首先谢谢海狸先生的无私共享。

可是，我发现个问题，还请教一下：

参见贴图--

[attach]12465[/attach]

[此贴子已经被作者于2005-8-15 20:43:57编辑过]

作者: 海狸先生 时间: 2005-8-16 04:54
修改了一下，加入防错On Error GoTo erritDim 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 Suberrit:

MsgBox "错误号为" & Err.Number & " 错误说明：" & Err.Description

Resume errexit

作者: wu8313 时间: 2005-8-16 05:09
上述问题已经不存在，感谢。相信，也是可以作为成熟代码来使用了。我原来，总是拐弯地的另存子窗体数据源为一个临时表，然后导出，看来应该改掉了，还是觉得海狸先生给出的好。

作者: LucasLynn 时间: 2005-8-16 16:21

以下是引用wu8313在2005-8-15 21:09:00的发言：

上述问题已经不存在，感谢。相信，也是可以作为成熟代码来使用了。

我原来，总是拐弯地的另存子窗体数据源为一个临时表，然后导出，看来应该改掉了，还是觉得海狸先生给出的好。

你这样做也有好处，就是能够导出成多种格式，各有各的优点。

作者: 红寺 时间: 2005-8-16 18:25
http://support.microsoft.com/kb/247412/这里比较全,可以看看

作者: chajiangliang 时间: 2005-8-16 19:04
用ADO來操作Excel 又快﹐又靈活. 除非要特別的格式化﹐一般的也都可以搞定.http://www.office-cn.net/forum.php?mod=viewthread&tid=30811

作者: 红寺 时间: 2005-8-16 19:32
请问楼上的

rivate Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _

               (ByVal hwnd As Long, ByVal lpszOp As String, _

                  ByVal lpszFile As String, ByVal lpszParams As String, _

                  ByVal LpszDir As String, ByVal FsShowCmd As Long) _

                  As Long

Private Const SW_NORMAL = 1此段代码什么情况下非要不可?我好像没看见哪里用到他

作者: chajiangliang 时间: 2005-8-16 19:57
打開文件時用到. ShellExecute Me.hwnd, "Open", App.Path & "\Results\Orders1.xls", "", "C:\", SW_SHOWNORMAL

作者: esmile 时间: 2005-8-17 05:43
提示: 作者被禁止或删除内容自动屏蔽

作者: 李寻欢 时间: 2005-8-17 06:15
标题: 凑凑热闹^_^
[attach]12491[/attach]

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

作者: 爱情插班生 时间: 2005-9-8 23:43
整理:1.子窗体导出,筛选,2. 奇怪的lookup_筛选字符....

并提出问题: 如何不导出隐藏列! swdq [attach]13010[/attach]

[em01][em01][em01]

[此贴子已经被作者于2005-9-9 17:45:01编辑过]

作者: hsn2914 时间: 2005-9-10 02:08
当一个掉到海里的人求救的时候，他所需要的是一个救生圈，而不是学游泳的方法。获救以后想必他自己会去学会游泳，因为不是每次都会有人及时地丢给你一个救生圈。非常感谢海狸先生！

作者: sea.er 时间: 2005-9-10 05:59
抛砖引玉，都是好东东[em02]

作者: GORYUNGBBS 时间: 2005-9-10 06:28
好东西,不过我不大明白.以下命令就可以实现. 不过没比较速度和格式如何.

docmd.OutputTo acOutputForm,formname,acformatXls,filename,autostart

作者: LucasLynn 时间: 2005-9-10 16:47

以下是引用hsn2914在2005-9-9 18:08:00的发言：

当一个掉到海里的人求救的时候，他所需要的是一个救生圈，而不是学游泳的方法。

获救以后想必他自己会去学会游泳，因为不是每次都会有人及时地丢给你一个救生圈。

非常感谢海狸先生！

我小时候我爸带我去江里手把手地教我学游泳，学了三年没学会，第四年夏天我爸不耐烦了，把我一个人丢在江中央，折腾到水面上快没动静了才把我捞上来，歇了一会儿又把我丢下去了，结果不到一礼拜，我就一个人在水里狗刨了。

作者: tmtony 时间: 2005-9-10 17:18

以下是引用LucasLynn在2005-9-10 8:47:00的发言：

我小时候我爸带我去江里手把手地教我学游泳，学了三年没学会，第四年夏天我爸不耐烦了，把我一个人丢在江中央，折腾到水面上快没动静了才把我捞上来，歇了一会儿又把我丢下去了，结果不到一礼拜，我就一个人在水里狗刨了。

倒是个好方法

作者: zyz218 时间: 2005-9-11 00:39
好贴就顶一下

作者: huanghai 时间: 2005-9-12 05:06
我也来加一帖，基础跟楼主的愿意差点不多，不家一种方法更简单，就是使用代码全选子窗体记录，然后复制，打开EXCEL粘贴即可，这样不要判断哪些字段显示了，哪些字段隐身了。我的代码如下。Function myOutputToExcel(Rst As Object) If (Rst.EOF Or Rst.BOF) And Rst.RecordCount = 0 Then

      MsgBox "没有可导出的数据！", vbQuestion, gAppTitle

      Exit Function

End If 'Dim xlsApp As Excel.Application

Dim xlsApp As Object Set xlsApp = CreateObject("Excel.Application")

xlsApp.Workbooks.Add

xlsApp.Visible = True Dim C As Integer With xlsApp.Workbooks(1).Worksheets(1)

      For C = 0 To Rst.Fields.Count - 1

         .Cells(1, C + 1) = Rst.Fields(C).Name

      Next

      Rst.MoveFirst

      .Cells(2, 1).CopyFromRecordset Rst

      .Cells.Select

      xlsApp.ActiveWindow.Selection.Font.Size = 9

      .Cells.EntireColumn.AutoFit

      .Cells(1, 1).Select End WithEnd Function

作者: 午夜兰花 时间: 2005-9-15 17:04
到底谁的方法最好啊？？？

作者: wxf16 时间: 2005-9-22 23:08
good

作者: wxf16 时间: 2005-9-22 23:09
好！

作者: wxf16 时间: 2005-9-22 23:09
[em01]

作者: congee 时间: 2005-9-29 00:48
很精彩的描述

作者: LucasLynn 时间: 2005-9-29 01:10
标题: 我也来凑个热闹
导出窗体Recordset为任意Access支持格式的数据文件

以下代码将DAO的RecordSet（包括Access窗体的Recordset）中的当前数据导出为任何Access支持的导出格式。无论你这个Recordset是从窗体的，还是代码创建的，是筛选后结果，还是链接了字段的主窗体，本程序均能正确导出结果，格式包括任何Access支持的导出格式。

'调用范例

Private Sub Botton_Click()

Call Output_Recordset(Me.Recordset)

End Sub

<DIV class=quote>

'公共模块

Option Compare Database

Option Explicit

Public Sub Output_Recordset(ByRef frmRs As DAO.Recordset)

Dim frmField As DAO.Field

Dim daoDbs As DAO.Database

Dim daoRs As DAO.Recordset

Dim strSQL As String

Dim strFields As String

Set daoDbs = Application.CurrentDb

Set daoRs = frmRs.Clone

strSQL = "CREATE TABLE USysDAORecordsetOutport"

strFields = "("

For Each frmField In daoRs.Fields

      strFields = strFields & frmField.Name & " "

      Select Case frmField.Type

         Case dbBigInt:

            strFields = strFields & "Currency"

         Case dbBinary:

            strFields = strFields & "Binary"

         Case dbBoolean:

            strFields = strFields & "Bit"

         Case dbByte:

            strFields = strFields & "TinyInt"

         Case dbChar:

            strFields = strFields & "Char"

         Case dbCurrency:

            strFields = strFields & "Money"

         Case dbDate:

            strFields = strFields & "DateTime"

         Case dbDecimal:

            strFields = strFields & "Decimal"

         Case dbDouble:

            strFields = strFields & "Double"

         Case dbFloat:

            strFields = strFields & "Float"

         Case dbGUID:

            strFields = strFields & "Guid"

         Case dbInteger:

            strFields = strFields & "Integer"

         Case dbLong:

            strFields = strFields & "Long"

         Case dbLongBinary:

            strFields = strFields & "LongBinary"

         Case dbMemo :

            strFields = strFields & "Memo"

         Case dbNumeric:

            strFields = strFields & "Numeric"

         Case dbSingle:

            strFields = strFields & "Single"

         Case dbText:

            strFields = strFields & "Text(" & frmField.Size & ")"

         Case dbTime:

            strFields = strFields & "Time"

         Case dbTimeStamp:

            strFields = strFields & "DateTime"

         Case dbVarBinary:

            strFields = strFields & "VarBinary"

      End Select



      strFields = strFields & ","

Next frmField

strFields = Left(strFields, Len(strFields) - 1) & ")"

On Error Resume Next

      daoDbs.Execute "DROP TABLE USysDAORecordsetOutport"

On Error GoTo 0

daoDbs.Execute strSQL & strFields

daoRs.MoveFirst

Do Until daoRs.EOF

      strSQL = "INSERT INTO USysDAORecordsetOutport("

      strFields = " Values("

      For Each frmField In daoRs.Fields

         If Not IsNull(frmField.Value) And Not IsEmpty(frmField.Value) Then

            strSQL = strSQL & frmField.Name & ","

            If frmField.Type = dbText Then

                  strFields = strFields & "'" & frmField.Value & "',"

            Else

                  strFields = strFields & frmField.Value & ","

            End If

         End If

      Next frmField

      strSQL = Left(strSQL, Len(strSQL) - 1) & ")"

      strFields = Left(strFields, Len(strFields) - 1) & ")"

      daoDbs.Execute strSQL & strFields

      daoRs.MoveNext

Loop

DoCmd.OutputTo acOutputTable, "USysDAORecordsetOutport"

daoDbs.Execute "DR

作者: zerosailing 时间: 2005-11-21 01:33
向无私的海里先生致敬！

作者: zerosailing 时间: 2005-11-21 01:40
还有Mr.LucasLynn和Mr. huanghai!!

作者: cdwlove 时间: 2005-12-5 21:35
有没有实例看看!!!

作者: ok003 时间: 2006-2-7 22:21

以下是引用esmile在2005-8-16 21:43:00的发言：

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

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

我试了一下很好用，只是第二次导出时得把第一次导出的book1.xls挪开或者改名，不然的话就得覆盖了，我想请问可不可以选择路径和文件名

？

作者: ok003 时间: 2006-2-7 22:48

以下是引用爱情插班生在2005-9-8 15:43:00的发言：

整理:1.子窗体导出,筛选,2. 奇怪的lookup_筛选字符....

并提出问题: 如何不导出隐藏列! swdq [attach]13010[/attach]
[em01][em01][em01]

还有就是怎么导出字段的标题？我的表格设置字段名为字母，标题是汉字，怎么可以导出去的xls表标题也是汉字？

比如我要导出去的子窗体字段引用为"xm"，字段的标题是"姓名"，我想要导出去的表，标题是"姓名"，而不是"xm"

[此贴子已经被作者于2006-2-7 14:49:09编辑过]

作者: h333 时间: 2006-4-28 00:45
真精彩

作者: ederais 时间: 2008-5-16 14:26
边顶边看边下～～

作者: ABCaccess 时间: 2008-6-1 12:57
谢谢你与大众分享

作者: chaojianan 时间: 2009-10-24 15:27
谢谢海狸先生。

作者: shines 时间: 2011-1-14 14:16
谢谢分享

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