【源码】一个用于将记录集数据导出到Excel的函数

红尘如烟

使用示例：
导出窗体数据：    ExportToExcel Me.Recordset, "C:\Test.xls"
导出子窗体数据：ExportToExcel Me.子窗体.Form.Recordset, "C:\Test.xls"
导出列表框数据：ExPortToExcel Me.List1.Recordset, "C:\Test.xls"

1. '======================================================================================================
   
2. '函数名称： ExportToExcel
   
3. '功能描述： 将记录集中的数据导出到Excel文件
   
4. '输入参数： rst                 必需的，用于导出数据的打开的记录集对象，可以使用窗体的Recordset属性
   
5. '                      FileName    必需的，导出的Excel文件存放路径名
   
6. '返回参数： 成功导出返回True，否则返回False
   
7. '使用说明： 可以对绑定窗体进行筛选，然后将窗体的Recrodset属性传递给rst参数，这样就可以将筛选结果导出，另
   
8. '                      外还可以用于导出列表框、组合框中的数据，同样只需要传递Recordset属性即可
   
9. '兼 容 性： 必须安装Excel，但无需引用
   
10. '作        者： 红尘如烟
    
11. '创建日期： 20010-10-14
    
12. '======================================================================================================
    
13. Function ExportToExcel(rst As Object, FileName As String) As Boolean
    
14. On Error GoTo Err_ExportToExcel
    
15.     Dim objExcelApp        As Object
    
16.     Dim objExcelBook      As Object
    
17.     Dim objExcelSheet     As Object
    
18.     Dim objExcelQuery     As Object
    
19.    
    
20.     If rst.RecordCount =0 Then
    
21.         MsgBox ("没有数据可导出！"), vbExclamation
    
22.         GoSub Exit_ExportToExcel
    
23.     End If
    
24.    
    
25.     If Dir(FileName) <> "" Then Kill FileName
    
26.    
    
27.     DoCmd.Hourglass True
    
28.    
    
29.     Set objExcelApp = CreateObject("Excel.Application")
    
30.     Set objExcelBook = objExcelApp.Workbooks().Add()
    
31.     Set objExcelSheet = objExcelBook.Worksheets("sheet1")
    
32.    
    
33.     Set objExcelQuery = objExcelSheet.QueryTables.Add(rst, objExcelSheet.Range("A1"))
    
34.     With objExcelQuery
    
35.             .FieldNames = True
    
36.             .FillAdjacentFormulas = False
    
37.             .PreserveFormatting = True
    
38.             .BackgroundQuery = True
    
39.             .RefreshStyle = 1 ' xlInsertDeleteCells
    
40.             .SavePassword = True
    
41.             .SaveData = True
    
42.             .AdjustColumnWidth = True
    
43.             .RefreshPeriod = 0
    
44.             .PreserveColumnInfo = True
    
45.     End With
    
46.       
    
47.     objExcelQuery.Refresh
    
48.    
    
49.     objExcelBook.Worksheets("sheet1").SaveAs FileName
    
50.     ExportToExcel = True
    
51.     If MsgBox("数据已导出，是否打开并查看？", vbQuestion + vbYesNo) = vbYes Then
    
52.         objExcelApp.Visible = True
    
53.     Else
    
54.         objExcelBook.Saved = True
    
55.         objExcelApp.Quit
    
56.     End If
    
57.    
    
58. Exit_ExportToExcel:
    
59.     Set objExcelApp = Nothing
    
60.     Set objExcelBook = Nothing
    
61.     Set objExcelSheet = Nothing
    
62.     Set rst = Nothing
    
63.     DoCmd.Hourglass False
    
64.     Exit Function
    
65.    
    
66. Err_ExportToExcel:
    
67.     If Err = 70 Then
    
68.         MsgBox "无法删除文件 '" & FileName & "'，可能该文件已被打开或没有权限。", vbCritical
    
69.     Else
    
70.         MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical
    
71.     End If
    
72.     Resume Exit_ExportToExcel
    
73. End Function
    
74. 
    

复制代码

yanwei82123300

谢谢分享

tmtony

好实例，谢谢 红尘 分享

xinbao

收藏了

鱼儿游游

导出子窗体数据 出错

zhoudb2010

me.子窗体.form.recordset出错呀，不支持该对象类型

szyewj

谢谢分享，收藏了

smilingkiss

多谢红尘分享，另想请教：如果我想导出的excel文件已经存在，如何让导出数据自动导出到该excel文件的一个新建工作表呢？

smilingkiss

谢谢

smilingkiss

大哥，我试过你的程序，第一次点击调用了该函数的按钮，导出的excel文件成功，但是关了excel后继续按那个按钮（也就是继续执行一次），结果导出来的excel只有标题栏，没有数据，只有把窗体关了重新打开才可以成功导出，百思不得其解啊，还请指教啊！