On Error Best Practices
An On Error code section should deactivate all memory-consuming objects. The code below shows how to use the On Error for a program that uses both Excel and Access objects in the same procedure.
Program Code
Private Sub cmdCreateProjectedToBuyReport_Click()
On Error GoTo Error_Handler
' **************************************************************
' Establish Database Query Connection
' **************************************************************
Dim db As DAO.Database
Dim recIn As DAO.Recordset
' **************************************************************
' Establish Excel Communications from Access
' **************************************************************
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlReport As Excel.Worksheet
' **************************************************************
' Other Variables
' **************************************************************
Dim lngRowCounter As Long
Dim strSaveAsName As String
' **************************************************************
' Get the user's name for the proper path to directories
' And set the template to use
' **************************************************************
strUserName = UserNameWindows()
strTemplateToUse = "ProjectedToBuyTemplateV2.xlsx"
' **************************************************************
' Set Proper Path To Templates And Report Save Area
' **************************************************************
Select Case Me.cmbUserPaths
Case "MARCO"
' strPathToTemplates = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\Templates\"
' strSavePath = "\\MPI-SERVER2\Users$\" & strUserName & "\Documents\SavedReports\"
strPathToTemplates = CurDir() & "\Templates\"
strSavePath = CurDir() & "\SavedReports\"
Case Else
strPathToTemplates = Me.cmbUserPaths.Column(1)
strSavePath = Me.cmbUserPaths.Column(2)
End Select
' **************************************************************
' Verify That The Projected To Buy Template Exists
' **************************************************************
If Not FileExists(strPathToTemplates & strTemplateToUse) Then
MsgBox (strPathToTemplates & strTemplateToUse & " Does Not Exist")
Exit Sub
End If
' **************************************************************
' Verify That The Save Directory Folder Exists
' **************************************************************
If Not FolderExists(strSavePath) Then
MsgBox (strSavePath & " Does Not Exist")
Exit Sub
End If
DoCmd.Hourglass True
' **************************************************************
' Create the Projected To Buy Table With Today's Data
' **************************************************************
Call CreateProjectedToBuyTableData
' ***********************************************************************
' Open the Projected To Buy Data
' ***********************************************************************
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryListProjectedToBuyTable", dbOpenSnapshot)
If recIn.RecordCount = 0 Then
GoTo Error_Handler_Exit
End If
' **************************************************************
' Open the Sales Compare Template
' **************************************************************
Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
Set xlWB = xlApp.Workbooks.Open(strPathToTemplates & strTemplateToUse)
Set xlReport = xlWB.Sheets("ProjectedToBuy")
' xlApp.Visible = True
' ***************************************************************
' Update the report header with today's date
' ***************************************************************
xlReport.Range("A1") = "Projected To Buy As Of " & Date
' ***************************************************************
' Loop through all the query records and insert them one row
' at a time into the template
' ***************************************************************
lngRowCounter = 3
Do
lngRowCounter = lngRowCounter + 1
' ***************************************************************
' Poulate the workbook with the Projected To Buy Balances
' ***************************************************************
xlReport.Cells(lngRowCounter, "A") = recIn!Item
xlReport.Cells(lngRowCounter, "B") = recIn!Description
xlReport.Cells(lngRowCounter, "C") = recIn!PhysicalOnHandBottles
xlReport.Cells(lngRowCounter, "D") = recIn!RawGoodsBottles
xlReport.Cells(lngRowCounter, "E") = recIn!PORawGoodsBottles
xlReport.Cells(lngRowCounter, "F") = recIn!POExpectedArrivalDate
xlReport.Cells(lngRowCounter, "G") = recIn!Physical_RG_PO_TotalBottles
xlReport.Cells(lngRowCounter, "H") = recIn!MonthlyTRBottles
xlReport.Cells(lngRowCounter, "I") = recIn!ProjectedMonthsInStock
xlReport.Cells(lngRowCounter, "J") = recIn!MonthsLeadTime
xlReport.Cells(lngRowCounter, "K") = recIn!NetAllowance
xlReport.Cells(lngRowCounter, "L") = recIn!MOQ
recIn.MoveNext
Loop Until recIn.EOF
' ********************************************************
' Save the File With A Unique Date and Time Stamp
' ********************************************************
strSaveAsName = strSavePath & "ProjectedToBuy_" & Format(Date, "YYYY_MM_DD") & "_" & Format(Hour(Now), "00") & Format(Minute(Now), "00")
xlWB.SaveAs FileName:=strSaveAsName, FileFormat:=xlOpenXMLWorkbook
' ********************************************************
' Message the user and display the location of the
' saved report
' ********************************************************
MsgBox ("The Report Was Saved to " & strSaveAsName)
Error_Handler_Exit:
DoCmd.Hourglass False
On Error Resume Next
If Not xlWB Is Nothing Then
xlApp.DisplayAlerts = False
xlWB.Close SaveChanges:=False
xlApp.DisplayAlerts = True
Set xlWB = Nothing
End If
If Not xlReport Is Nothing Then Set xlReport = Nothing
If Not xlApp Is Nothing Then
xlApp.Quit
Set xlApp = Nothing
End If
If Not recIn Is Nothing Then
recIn.Close
Set recIn = Nothing
End If
If Not db Is Nothing Then Set db = Nothing
Exit Sub
Error_Handler:
MsgBox "An Error Occurred In This Application" & vbCrLf & _
"Please Contact The Developer" & vbCrLf & vbCrLf & _
"Error Number = " & Err.Number & " Error Description = " & _
Err.Description, vbCritical
Resume Error_Handler_Exit
End Sub