<output id="os3gq"><ruby id="os3gq"></ruby></output>

    1. <mark id="os3gq"></mark>
    2. 5個免費課程
      網站公告
      ·Access快速平臺QQ群號:156702533    ·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交流群 (群號:32587638)       access源碼網店

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

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

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

      用戶名:
      密 碼:
      內 容:
       

      常見問答

      技術分類

      相關資源

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