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

来源:原创 点击数:101963 　 | 收藏 | 复制

时　间:2010-10-14 13:33:11
作　者:红尘如烟 ID：10768 城市：成都
摘　要:一个用于将记录集数据导出到Excel的函数
使用示例：
导出窗体数据： ExportToExcel Me.Recordset, "C:\Test.xls"
导出子窗体数据：ExportToExcel Me.子窗体.Form.Recordset, "C:\Test.xls"
导出列表框数据：ExPortToExcel Me.List1.Recordset, "C:\Test.xls"

正　文:

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

'==================================================================
'函数名称： ExportToExcel
'功能描述：将记录集中的数据导出到Excel文件
'输入参数： rst                 必需的，用于导出数据的打开的记录集对象，可以使用窗体的Recordset属性
'                      FileName    必需的，导出的Excel文件存放路径名
'返回参数：成功导出返回True，否则返回False
'使用说明：可以对绑定窗体进行筛选，然后将窗体的Recrodset属性传递给rst参数，这样就可以将筛选结果导出，另
'                      外还可以用于导出列表框、组合框中的数据，同样只需要传递Recordset属性即可
'兼容性：必须安装Excel，但无需引用
'作        者：红尘如烟
'创建日期： 20010-10-14
'==================================================================
Function ExportToExcel(rst As Object, FileName As String) As Boolean
On Error GoTo Err_ExportToExcel
    Dim objExcelApp        As Object
    Dim objExcelBook      As Object
    Dim objExcelSheet     As Object
    Dim objExcelQuery     As Object

    If rst.RecordCount < 1 Then
        MsgBox ("没有数据可导出！"), vbExclamation
        GoSub Exit_ExportToExcel
    End If

    If Dir(FileName) <> "" Then Kill FileName

    DoCmd.Hourglass True

    Set objExcelApp = CreateObject("Excel.Application")
    Set objExcelBook = objExcelApp.Workbooks().Add()
    Set objExcelSheet = objExcelBook.Worksheets("sheet1")

    Set objExcelQuery = objExcelSheet.QueryTables.Add(rst, objExcelSheet.Range("A1"))
    With objExcelQuery
            .FieldNames = True
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .BackgroundQuery = True
            .RefreshStyle = 1 ' xlInsertDeleteCells
            .SavePassword = True
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .PreserveColumnInfo = True
    End With

    objExcelQuery.Refresh

    objExcelBook.Worksheets("sheet1").SaveAs FileName
    ExportToExcel = True
    If MsgBox("数据已导出，是否打开并查看？", vbQuestion + vbYesNo) = vbYes Then
        objExcelApp.Visible = True
    Else
        objExcelBook.Saved = True
        objExcelApp.Quit
    End If

Exit_ExportToExcel:
    Set objExcelApp = Nothing
    Set objExcelBook = Nothing
    Set objExcelSheet = Nothing
    Set rst = Nothing
    DoCmd.Hourglass False
    Exit Function

Err_ExportToExcel:
    If Err = 70 Then
        MsgBox "无法删除文件 '" & FileName & "'，可能该文件已被打开或没有权限。", vbCritical
    Else
        MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical
    End If
    Resume Exit_ExportToExcel
End Function

Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店

【打印此文】【关闭窗口】