导出至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

测试示例下载：

点击下载此附件