导出至Excel系列方法五CopyFromRecordset
时 间:2019-09-03 09:27:46
作 者:金宇 ID:43 城市:江阴
摘 要:此方法是借用Excel中Range对象的CopyFromRecordset方法实现数据的导出。
正 文:
此方法是借用Excel中Range对象的CopyFromRecordset方法实现数据的导出,将 ADO 或 DAO Recordset(记录集) 对象的内容复制到工作表中(从指定区域的左上角开始)。 如果 Recordset 对象包含具有 OLE 对象的字段,则该方法无效。此方法还有一个缺点,就是导出数据到Excel时不带有标题,需要自己处理增加字段标题。
关于此方法的使用我写了一个专门的函数,可以直接调用便于数据导出至Excel,调用方法如下:
ExportToExcelCopyFromRecordset "Products", "select [Supplier IDs],ID,[Product Code],[Product Name],[Description] from Products"
"Products" 就指工作薄的名称。
"select [Supplier IDs],ID,[Product Code],[Product Name],[Description] from Products" 是需要导出数据的SQL语句。
函数说明:
'========================================================================================= '函数名称: ExportToExcelCopyFromRecordset '功能描述: 将 ADO 或 DAO 记录集对象中的内容复制到Excel工作表 '输入参数: WorkbookName 必需的,工作簿名称 ' strSQL 必需的,SQL语句,不能包含具有 OLE 对象的字段,否则该方法无效。 '返回参数: 无 '使用说明: 由于采用的复制粘贴数据的方法,所以如果要导出子窗体数据,必须先让子窗体获得焦点 ' 如果是导出主窗体数据,则主窗体中的焦点控件不能是子窗体,必须先将焦点从子窗体移开 '兼 容 性: '作 者: 金宇 '创建日期: 2013-11-5 '========================================================================================= Function ExportToExcelCopyFromRecordset(ByVal WorkbookName As String, ByVal strSQL As String) On Error GoTo Err_ExportToExcel Dim objExcel As Object Dim objBook As Object Dim objSheet As Object Dim objRange As Object Dim rst As Object Dim cnn As Object Dim strFileName As String Dim strExtName As String Dim lngRow As Long Dim lngColumn As Long Dim FirstRange As String Const xlLastCell = 11 Const xlCenter = -4108 Const xlEdgeLeft = 7 Const xlEdgeTop = 8 Const xlEdgeBottom = 9 Const xlEdgeRight = 10 Const xlInsideVertical = 11 Const xlInsideHorizontal = 12 Const xlContinuous = 1 Const xlDiagonalDown = 5 Const xlDiagonalUp = 6 Const xlNone = -4142 '根据当前版本取得对应的文件扩展名 strExtName = ".xls" If Val(Application.Version) > 11 Then strExtName = ".xlsx" '取得另存为文件名 With Application.FileDialog(2) 'msoFileDialogSaveAs .InitialFileName = WorkbookName & strExtName If Not .Show Then Exit Function strFileName = .SelectedItems(1) If Not strFileName Like "*" & strExtName Then strFileName = strFileName & strExtName End If If Len(Dir(strFileName)) > 0 Then Kill strFileName End With DoCmd.Hourglass True Set cnn = CurrentProject.Connection Set objExcel = CreateObject("Excel.Application") objExcel.Visible = False Set objBook = objExcel.Workbooks.Add 'objBook.Worksheets.Add().Select Set objSheet = objBook.Worksheets.Add 'Set objSheet = objBook.Worksheets("sheet1") objSheet.Name = WorkbookName '工作表名称 '由于CopyFromRecordset 方法不返回字段标题,需要自己处理增加字段标题 Set rst = CurrentProject.Connection.Execute(strSQL) For intI = 0 To rst.Fields.Count - 1 ' strName = "" ' strName = rst.Fields(intI).Properties("Caption") ' If strName = "" Then strName = rst.Fields(intI).Name objExcel.ActiveSheet.Cells(1, intI + 1) = rst.Fields(intI).Name Next objExcel.ActiveSheet.Range("A2").CopyFromRecordset cnn.Execute(strSQL) cnn.Close objExcel.ActiveCell.SpecialCells(xlLastCell).select lngRow = objExcel.ActiveCell.Row lngColumn = objExcel.ActiveCell.Column '格式化Excel Set objRange = objSheet.Range("A1", objExcel.ActiveCell) objRange.select With objRange .RowHeight = 15 '.ColumnWidth = 50 .EntireColumn.AutoFit .VerticalAlignment = xlCenter '垂直对齐 不引用excel控件的话只能使用xlCenter .HorizontalAlignment = xlCenter '水平对齐 不引用excel控件的话只能使用xlCenter .WrapText = True '文字自动换行 .Font.Name = "Calibri" .Font.Size = 10 .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone .Borders(xlInsideVertical).LineStyle = xlContinuous .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous End With ' objSheet.Rows(1).RowHeight = 27 'objExcel.Range("A1").Select objExcel.ActiveWindow.SplitRow = 1 '拆分第一行 objExcel.ActiveWindow.FreezePanes = True '固定拆分 ' objExcel.Visible = True objBook.SaveAs strFileName Exit_ExportToExcel: Set rst = Nothing Set cnn = Nothing Set objSheet = Nothing Set objBook = Nothing Set objExcel = Nothing DoCmd.Hourglass False Exit Function Err_ExportToExcel: Resume Exit_ExportToExcel End Function
测试示例下载:
Access软件网QQ交流群 (群号:54525238) Access源码网店
常见问答:
技术分类:
源码示例
- 【源码QQ群号19834647...(12.17)
- 【Access选项卡示例】Ac...(09.09)
- 【Access源码示例】按输入...(09.02)
- 【Access日期区间段查询】...(08.29)
- 【Access日期区间段查询】...(08.27)
- Access怎样才能实现日期时...(08.21)
- 【Access定时打开查询】A...(08.19)
- Access生成固定数量的记录...(08.13)
- Access怎样才能实现日期时...(08.12)
- Access利用导航窗体控件对...(08.03)
学习心得
最新文章
- Access表中的字段名、字段标题...(09.19)
- Access快速开发平台--更改“...(09.18)
- 【中秋及国庆优惠】Access培训...(09.15)
- Access如何将日期型的数值转换...(09.14)
- 英文输入法输入数据中存在单引号引起...(09.11)
- 【Access选项卡示例】Acce...(09.09)
- 让Access光标停留在指定的控件...(09.07)
- 关于Access查询条件里使用通配...(09.06)
- Access报表偷懒制作法--Ac...(09.05)
- Access快速开发平台--窗体数...(09.04)