【源碼】一個用于將記錄集數(shù)據(jù)導(dǎo)出到Excel的函數(shù)

紅塵如煙

使用示例：
導(dǎo)出窗體數(shù)據(jù)：    ExportToExcel Me.Recordset, "C:\Test.xls"
導(dǎo)出子窗體數(shù)據(jù)：ExportToExcel Me.子窗體.Form.Recordset, "C:\Test.xls"
導(dǎo)出列表框數(shù)據(jù)：ExPortToExcel Me.List1.Recordset, "C:\Test.xls"

1. '======================================================================================================
   
2. '函數(shù)名稱： ExportToExcel
   
3. '功能描述： 將記錄集中的數(shù)據(jù)導(dǎo)出到Excel文件
   
4. '輸入?yún)��?shù)： rst                 必需的，用于導(dǎo)出數(shù)據(jù)的打開的記錄集對象，可以使用窗體的Recordset屬性
   
5. '                      FileName    必需的，導(dǎo)出的Excel文件存放路徑名
   
6. '返回參數(shù)： 成功導(dǎo)出返回True，否則返回False
   
7. '使用說明： 可以對綁定窗體進行篩選，然后將窗體的Recrodset屬性傳遞給rst參數(shù)，這樣就可以將篩選結(jié)果導(dǎo)出，另
   
8. '                      外還可以用于導(dǎo)出列表框、組合框中的數(shù)據(jù)，同樣只需要傳遞Recordset屬性即可
   
9. '兼 容 性： 必須安裝Excel，但無需引用
   
10. '作        者： 紅塵如煙
    
11. '創(chuàng)建日期： 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 ("沒有數(shù)據(jù)可導(dǎo)出！"), 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("數(shù)據(jù)已導(dǎo)出，是否打開并查看？", 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 & "'，可能該文件已被打開或沒有權(quán)限。", vbCritical
    
69.     Else
    
70.         MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical
    
71.     End If
    
72.     Resume Exit_ExportToExcel
    
73. End Function
    
74. 
    

復(fù)制代碼

yanwei82123300

謝謝分享

tmtony

好實例，謝謝 紅塵 分享

xinbao

收藏了

魚兒游游

導(dǎo)出子窗體數(shù)據(jù) 出錯

zhoudb2010

me.子窗體.form.recordset出錯呀，不支持該對象類型

szyewj

謝謝分享，收藏了

smilingkiss

多謝紅塵分享，另想請教：如果我想導(dǎo)出的excel文件已經(jīng)存在，如何讓導(dǎo)出數(shù)據(jù)自動導(dǎo)出到該excel文件的一個新建工作表呢？

smilingkiss

謝謝

smilingkiss

大哥，我試過你的程序，第一次點擊調(diào)用了該函數(shù)的按鈕，導(dǎo)出的excel文件成功，但是關(guān)了excel后繼續(xù)按那個按鈕（也就是繼續(xù)執(zhí)行一次），結(jié)果導(dǎo)出來的excel只有標題欄，沒有數(shù)據(jù)，只有把窗體關(guān)了重新打開才可以成功導(dǎo)出，百思不得其解啊，還請指教啊！