Access培訓
網站公告
·Access快速平臺QQ群號:277422564    ·Access快速開發平臺下載地址及教程    ·歡迎添加微信交流賬號:AccessoftChu    ·如何快速搜索本站文章|示例|資料    
您的位置: 首頁 > 技術文章 > 源碼示例

導出至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交流群 (群號:198347485)       access源碼網店

最新評論 查看更多評論(1)

2019/9/4 0:09:58麥田

發表評論您的評論將提升作者分享的動力!快來評論一下吧!

用戶名:
密 碼:
內 容:
 

常見問答

技術分類

相關資源

關于我們 | 服務條款 | 在線投稿 | 友情鏈接 | 網站統計 | 網站幫助