【源码】一个用于将记录集数据导出到Excel的函数 - Office中国论坛/Access中国论坛

'======================================================================================================
'函数名称： 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 =0 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

复制代码