Option Compare Database
Option Explicit
'Custom Type used in ExportToExcel.
Private Type NameCheckResults
ResultMsg As String
IsDupe As Boolean
End Type
Public Function ExportToExcel(ByRef rs As DAO.Recordset, _
ByVal OutputPath As String, _
Optional ByVal TopLeft As String = "A1", _
Optional ByRef SheetName As String = "Sheet1", _
Optional ByVal ReplaceExisting As Boolean = False, _
Optional ByVal AddSheet As Boolean = False, _
Optional ByVal IncludeColumnNames As Boolean = False, _
Optional ByVal AutoFitData As Boolean = True, _
Optional ByVal AppendData As Boolean = False, _
Optional ByVal ShowFile As Boolean = False) As Integer
'*************************************************
'Version: 1.1.5
'Created By: Scott L Prince
'Date Created: 6/8/2016
'Revised By: Scott L Prince
'Date Revised: 11/30/2016
'Purpose: Exports a recordset to Excel.
'Parameters: An open recordset containing the data to be exported
' A string containing the full path for the file to be appended or created
' Optional - The location of the top-left cell for the exported dataset. Defaults to "A1".
' Optional - The name of the created worksheet. Defaults to 'Sheet 1'.
' Optional - Whether or not to replace any existing workbook of the same name and location. Defaults to FALSE.
' Optional - Whether or not to add the recordset as a new worksheet if the destination workbook already exists. Defaults to FALSE.
' Optional - Whether or not to append the data to an existing sheet. !!!THIS CAN OVERWRITE EXISTING DATA!!! Defaults to FALSE.
' AppendData overrides ReplaceExisting and AddSheet, and should only be used when adding multiple recordsets to one worksheet.
'Returns: Success/Failure Code:
' 0 - Uncaught/unhandled exception
' 1 - Output file already exists, user chose to cancel rather than replace the file
' 2 - Output sheet already exists in output file and user chose to cancel
' 3 - Output file already exists and is locked
' 999 - Successful save
'Dependencies: Requires CheckFileLock procedure from modFileUtilities
' Requires FileExists procedure from modFileUtilities
'Comments: If additional option types or option locations are added, ensure that this module is updated to reflect this.
' This procedure saves the spreadsheet as the default for whichever version of Excel is being used
' Excel 97 to 2003: .xls
' Excel 2007 or later: .xlsx
'*************************************************
'Edited By: Scott L Prince
'Edit Date: 10/19/2016
'Description: Revised to add checks for valid worksheet names.
'*************************************************
'Edited By: Scott L Prince
'Edit Date: 10/27/2016
'Description: Revised to clean up logic errors and remove default sheets from new workbooks.
'*************************************************
'Edited By: Scott L Prince
'Edit Date: 11/01/2016
'Description: Revised to allow data to be appended to existing worksheets.
'*************************************************
'Edited By: Scott L Prince
'Edit Date: 11/30/2016
'Description: Added explicit sheet selection to avoid an assortment of Excel errors arising from modifying non-selected sheet.
'*************************************************
'Edited By: Scott L Prince
'Edit Date: 08/16/2017
'Description: Changed SheetName parameter to ByRef to account for the possibiity of changing the worksheet name mid-procedure.
'*************************************************
On Error GoTo E2E_Err
'Dim wb As Excel.Workbook
'Dim ws As Excel.Worksheet
'Dim xl As Excel.Application
Dim wb As Object
Dim ws As Object
Dim xl As Object
Dim NameCheck As NameCheckResults
Dim PH As String
PH = "E2EPlaceholder"
'Const PH = "E2EPlaceholder" 'Used as the name of a placeholder worksheet name. If changed, ensure it is one that will never actually be used.
'Defaults
If Nz(SheetName, "") = "" Then SheetName = "Sheet1"
'Determine whether or not target workbook already exists.
If FileExists(OutputPath) Then
'File exists. Check to see if ReplaceExisting is set to TRUE.
If Not ReplaceExisting And Not AppendData Then
'ReplaceExisting is not set to true - check AddSheet (if RE is FALSE and AS is TRUE, there is no reason to query the user.)
If Not AddSheet Then
'Ask the user if they want to replace the existing file.
Select Case MsgBox("File already exists. Do you want to replace it?", vbYesNo + vbCritical + vbDefaultButton2, PROJECT_NAME)
Case vbYes
'User okayed replacing the file, so change ReplaceExisting to TRUE.
ReplaceExisting = True
Case vbNo
'User does not want to replace the file. Determine if they want to add the data to the existing file in a new worksheet.
If MsgBox("Do you wish to add a worksheet with this data to the existing file?", vbYesNoCancel + vbInformation + vbDefaultButton3, PROJECT_NAME) = vbYes Then
'Change the AddSheet flag to TRUE
AddSheet = True
Else
'User chose to neither kill the existing file nor add a sheet to it. Return result code and terminate processing.
ExportToExcel = 1
Err.Raise 500
End If
Case Else
'User either closed the message box or selected 'Cancel'. Return result code and terminate processing.
ExportToExcel = 1
Err.Raise 500
End Select
End If
End If
'Determine if the destination file is locked.
If CheckFileLock(OutputPath) Then
'File is in use. Return error code and terminate processing.
ExportToExcel = 3
Err.Raise 500
End If
'Open Excel
Set xl = CreateObject("Excel.Application")
'File is not locked. Check value of ReplaceExisting.
If ReplaceExisting Then
'File is to be replaced. Delete the existing copy.
Kill OutputPath
'Create the output workbook.
Set wb = xl.Workbooks.Add
'Create a placeholder sheet.
Set ws = wb.Sheets.Add
ws.Name = PH
Set ws = Nothing
'Delete all other sheets.
For Each ws In wb.Sheets
If ws.Name <> PH Then ws.Delete
Next ws
'Save the workbook.
wb.SaveAs OutputPath
Else
'File is not to be replaced, and AddSheet is TRUE. (FALSE results would be aborted above.) Open the existing file.
Set wb = xl.Workbooks.Open(OutputPath)
End If
'Verify that the provided sheet name, if any, is valid.
Do
NameCheck = ValidateWSName(wb, SheetName)
If NameCheck.ResultMsg <> "" Then
SheetName = InputBox(NameCheck.ResultMsg & vbCrLf & vbCrLf & "Please enter a valid worksheet name. Leave blank to cancel.", PROJECT_NAME, "Sheet1")
If SheetName = "" Then
ExportToExcel = 2
Err.Raise 500
End If
End If
Loop Until NameCheck.ResultMsg = ""
If NameCheck.IsDupe And Not AppendData Then
Select Case MsgBox("The worksheet '" & SheetName & "' already exists. Do you wish to replace it?", vbCritical + vbYesNoCancel + vbDefaultButton3, PROJECT_NAME)
Case vbYes
'Delete the existing sheet and set IsDupe to false.
xl.DisplayAlerts = False
wb.Sheets(SheetName).Delete
xl.DisplayAlerts = True
NameCheck.IsDupe = False
Case vbNo
'Verify the worksheet name.
Do Until NameCheck.ResultMsg = "" And Not NameCheck.IsDupe
'Ask the user for a new worksheet name.
If NameCheck.IsDupe Then
SheetName = InputBox("The worksheet name you provided already exists. Please provide a different worksheet name. Leave blank to cancel.", _
PROJECT_NAME, "Sheet1")
Else
SheetName = InputBox(IIf(Nz(NameCheck.ResultMsg, "") = "", "", NameCheck.ResultMsg & vbCrLf & vbCrLf) & _
"Please enter a valid worksheet name. Leave blank to cancel.", PROJECT_NAME, "Sheet1")
End If
If SheetName = "" Then
ExportToExcel = 2
Err.Raise 500
End If
NameCheck = ValidateWSName(wb, SheetName)
Loop
Case vbCancel
ExportToExcel = 2
Err.Raise 500
End Select
End If
'If NameCheck.IsDupe is false, create a worksheet after all existing ones. (Will only be true if AppendData is true.)
If Not NameCheck.IsDupe Then
Set ws = wb.Worksheets.Add(, wb.Worksheets(wb.Worksheets.Count))
ws.Name = SheetName
End If
'Delete the sheet E2EPlaceholder if it exists.
If Not ws Is Nothing Then Set ws = Nothing
For Each ws In wb.Sheets
If ws.Name = PH Then ws.Delete
Next ws
'Re-select the new sheet.
Set ws = wb.Worksheets(SheetName)
'Save the workbook.
wb.Save
Else
'Output file doesn't already exist, so create it.
'Open Excel.
Set xl = CreateObject("Excel.Application")
'Create the output workbook.
Set wb = xl.Workbooks.Add
'Delete all sheets save the first one.
For Each ws In wb.Sheets
If ws.Index <> 1 Then ws.Delete
Next ws
'Select the only remaining worksheet in the workbook.
Set ws = wb.Sheets(1)
'Verify that the provided sheetname is valid.
If ws.Name <> SheetName Then
Do
NameCheck = ValidateWSName(wb, SheetName)
If NameCheck.ResultMsg <> "" Then
'Note - there is no Dupe check because there is only one worksheet remaining, and we're setting its name, so only name validity matters.
SheetName = InputBox(IIf(Nz(NameCheck.ResultMsg, "") = "", "", NameCheck.ResultMsg & vbCrLf & vbCrLf) & _
"Please enter a valid worksheet name. Leave blank to cancel.", PROJECT_NAME, "Sheet 1")
If SheetName = "" Then
ExportToExcel = 2
Err.Raise 500
End If
End If
Loop Until NameCheck.ResultMsg = ""
'Set the name of the worksheet to SheetName.
ws.Name = SheetName
End If
'Save the workbook.
wb.SaveAs OutputPath
End If
Dim CurrentRow As Long
Dim CurrentColumn As Long
'Ensure that the worksheet ws is selected.
ws.Select
'Assign row and column numbers to counters.
CurrentRow = ws.Range(TopLeft).Row 'Used to track the row of the 'pointer'.
CurrentColumn = ws.Range(TopLeft).Column 'Used primarily to cut down the number of function calls.
'Determine if column names are to be transferred.
If IncludeColumnNames Then
Dim ColCount As Long
For ColCount = 0 To rs.Fields.Count - 1
ws.Cells(CurrentRow, ColCount + 1).Value = rs.Fields(ColCount).Name
Next ColCount
ws.Range(xl.Cells(CurrentRow, CurrentColumn), xl.Cells(CurrentRow, CurrentColumn + rs.Fields.Count - 1)).Font.Bold = True
CurrentRow = CurrentRow + 1
End If
'Copy the submitted recordset to the output spreadsheet.
ws.Cells(CurrentRow, CurrentColumn).CopyFromRecordset rs
'Check to see if the exported data columns should be resized.
If AutoFitData Then
'Resize the rows to fit.
ws.UsedRange.Columns.AutoFit
End If
'Save the workbook.
wb.Save
'Return a 'Success' result
ExportToExcel = 999
E2E_Exit:
On Error Resume Next
If Not ws Is Nothing Then Set ws = Nothing
If Not wb Is Nothing Then
wb.Save
wb.Close
Set wb = Nothing
End If
If Not xl Is Nothing Then
xl.Quit
Set xl = Nothing
End If
Exit Function
E2E_Err:
Trap.Handle "basExcelUtilities", "ExportToExcel"
Resume E2E_Exit
End Function
Public Function ValidateWSName(ByRef wb As Object, _
ByVal WSName As String) As NameCheckResults
On Error GoTo VWN_Err
Dim ws As Variant
Dim x As Long
Dim Msg As String
Msg = "Please correct the following errors with the provided worksheet name:" & vbCrLf
'Length check
If Len(WSName) > 31 Then Msg = Msg & vbCrLf & "*Worksheet names may not exceed 31 characters in length."
ValidateWSName.IsDupe = False
'Duplicate check
For Each ws In wb.Sheets
If WSName = ws.Name Then
ValidateWSName.IsDupe = True
Exit For
End If
Next ws
'Special character check
If CheckSpecChars(WSName) Then Msg = Msg & vbCrLf & "The following characters may not be used in worksheet names: \/[]*:?"
'Results
If Msg <> "Please correct the following errors with the provided worksheet name:" & vbCrLf Then
ValidateWSName.ResultMsg = Msg
Else
ValidateWSName.ResultMsg = ""
End If
VWN_Exit:
Exit Function
VWN_Err:
Trap.Handle "basExcelUtilities", "ValidateWSName"
Resume VWN_Exit
End Function
Private Function CheckSpecChars(ByVal SheetName As String) As Boolean
Dim SpecChars() As String
Dim x As Long
CheckSpecChars = False
SpecChars() = Split("\,/,*,[,],:,?", ",")
'Special character check
For x = LBound(SpecChars) To UBound(SpecChars)
If InStr(1, SheetName, SpecChars(x), vbTextCompare) > 0 Then
CheckSpecChars = True
Exit For
End If
Next x
End Function
Public Function IsExcelRunning() As Boolean
Dim xlApp As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
IsExcelRunning = (Err.Number = 0)
Set xlApp = Nothing
Err.Clear
End Function
Function GetColumnLetter(ColumnNumber As Long) As String
Dim n As Long
Dim c As Byte
Dim s As String
n = ColumnNumber
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
GetColumnLetter = s
End Function