Public Sub cmdExport_Click()
Call ExportRecordset2XLS(Me.RecordsetClone)
End Sub
'---------------------------------------------------------------------------------------
' Procedure : ExportRecordset2XLS
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Export the passed recordset to Excel
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' rs : Recordset object to export to excel
'
' Usage:
' ~~~~~~
' Call ExportRecordset2XLS(Me.RecordsetClone)
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2017-Mar-13 Initial Release
' 2 2018-09-20 Updated Copyright
'---------------------------------------------------------------------------------------
Public Sub ExportRecordset2XLS(ByVal rs As DAO.Recordset)
'#Const EarlyBind = True 'Use Early Binding, Req. Reference Library
#Const EarlyBind = False 'Use Late Binding
#If EarlyBind = True Then
'Early Binding Declarations
Dim oExcel As Excel.Application
Dim oExcelWrkBk As Excel.Workbook
Dim oExcelWrSht As Excel.Worksheet
#Else
'Late Binding Declaration/Constants
Dim oExcel As Object
Dim oExcelWrkBk As Object
Dim oExcelWrSht As Object
Const xlCenter = -4108
#End If
Dim bExcelOpened As Boolean
Dim iCols As Integer
'Start Excel
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one
Err.Clear
On Error GoTo Error_Handler
Set oExcel = CreateObject("Excel.Application")
bExcelOpened = False
Else 'Excel was already running
bExcelOpened = True
End If
On Error GoTo Error_Handler
oExcel.ScreenUpdating = False
oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation
Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook
Set oExcelWrSht = oExcelWrkBk.Sheets(1)
With rs
If .RecordCount <> 0 Then
.MoveFirst 'This is req'd, had some strange behavior in certain instances without it!
'Build our Header
'****************
For iCols = 0 To rs.Fields.Count - 1
oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
'Format the header
With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
oExcelWrSht.Cells(1, iCols))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
'Copy the data from our query into Excel
'***************************************
oExcelWrSht.Range("A2").CopyFromRecordset rs
'Some formatting to make things pretty!
'**************************************
'Freeze pane
oExcelWrSht.Rows("2:2").Select
With oExcel.ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
'AutoFilter
oExcelWrSht.Rows("1:1").AutoFilter
'Fit the columns to the content
oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
oExcelWrSht.Cells(1, iCols)).EntireColumn.AutoFit
'Start at the top
oExcelWrSht.Range("A1").Select
Else
MsgBox "There are no records returned by the specified queries/SQL statement.", _
vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
GoTo Error_Handler_Exit
End If
End With
Error_Handler_Exit:
On Error Resume Next
oExcel.Visible = True 'Make excel visible to the user
Set rs = Nothing
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
oExcel.ScreenUpdating = True
Set oExcel = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: ExportRecordset2XLS" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
