So maybe that scenario isn't entirely applicable, but it can happen if you ignore error handling. A robust error handling system is a must for any app, but you won't find many code samples available on the Internet showing you how to apply a robust error handling solution. So I've put this module together; it shows both my global error handling procedure and how I programmatically automate the deployment into my applications.
Simple error handling pops up a MsgBox in order to avoid breaking the code. Good error handling logs the errors. My solution takes both and adds emailing an error notification to a GMail address you set up yourself (see http://tophersaccesstips.blogspot.com/2013/10/avoid-outlook-integration-send-email.html). But the real elegance in this code module is in the deployment routine - it finds every code module - standard, form, and report, in your application and adds the global error handler to each procedure (function or subroutine) in the module. Here are the steps:
1. Insert the following code module into a database. If you are developing multiple databases for a single client, the best place for this module is a shared "library" database (more on using library databases in a future post).
2. Run the InsertErrorHandling function by passing it the path to a valid MS Access database. In the Immediate window, Type
InsertErrorHandling "Path\To\My\Database.accdb"3. The procedure will open each code module in your database and add error handling. You may have to babysit this process, especially if your application contains a lot of orphaned objects.
4. When the procedure is finished, it will close the database and open a log file containing all of the modules and procedures it evaluated, along with whether it already had error-checking or not (True if it did, False if not). Perhaps counterintuitively, a False result means the procedure did add error checking to the procedure.
5. Reopen the database, checking to ensure that everything is working properly.
6. Even if everything looks okay, you should still compile the code to be sure. In the VBE, run the compiler (Debug -> Compile Database) and fix any errors that are noted. The better your code is written, the fewer the errors you should need to fix.
7. Enjoy your new, fully error-handled database!
NOTE: This module does not convert macros to VBA code to add error handling. I'm still looking into making that functionality available to the procedure.
Option Compare Database
Option Explicit
'***********************************************************
' Module GlobalErrorHandling
' Written by Topher Ritchie, tophersaccesstips.blogspot.com
' You are free to use, modify, or distribute this code, provided
' this header remains in place.
'***********************************************************
'psubGlobalErrHandler
' Provides consistent error handling
' Uses the SendSMTP function available at
' http://tophersaccesstips.blogspot.com/2013/10/avoid-outlook-integration-send-email.html)
Public Sub psubGlobalErrHandler(procedure_name As String, object_name As String, err_num As Long, err_desc As String)
On Error Resume Next
Dim fso As Object
Dim logfile As Object
Dim strError As String
MsgBox "Error " & err_num & " in " & procedure_name & ":" & vbCrLf & err_desc & vbCrLf & vbCrLf & "Please contact your application support team."
Set fso = CreateObject("Scripting.FileSystemObject")
Set logfile = fso.OpenTextFile(Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\YourApp_errors.log", ForAppending, True)
strError = CurrentDb.Name & "; " & CurrentProject.Name & "; " & procedure_name & "; " & object_name & "; " & err_num & "; " & err_desc & "; " & Now() & "; " & TempVars!CurrentUser & "; "
logfile.WriteLine strError
'add session data when available (open modules, windows, etc.) to handle tricky errors
If SendSMTP("you.developer@gmail.com", "Error triggered in Your App.", strError) Then
logfile.WriteLine "Error report sent"
Else
logfile.WriteLine "Error report NOT sent"
End If
logfile.Close
Set logfile = Nothing
Set fso = Nothing
End Sub
'The remainder of this module is for inserting Global Error Handling into procedures
' that do not already have it (in standard, form, and report modules), populating
' for psubGlobalErrHandler
Public Sub InsertErrorHandling(ByVal strDatabasePath As String)
Dim appAccess As Object
Dim obj As Object
Dim mdl As Object
Dim fs As Object, txtfile As Object
Set appAccess = New Access.Application
appAccess.OpenCurrentDatabase strDatabasePath
Set fs = CreateObject("Scripting.FileSystemObject")
Set txtfile = fs.OpenTextFile(CurrentProject.Path & "\errhandling.txt", 8, True)
txtfile.WriteLine appAccess.CurrentDb.Name
txtfile.WriteLine ""
txtfile.Close
Set txtfile = Nothing
Set fs = Nothing
For Each obj In appAccess.CurrentProject.AllModules
On Error GoTo NextModule
appAccess.DoCmd.OpenModule obj.Name
FixModule appAccess.Modules(obj.Name)
appAccess.DoCmd.Close acModule, obj.Name, acSaveYes
NextModule:
Next obj
For Each obj In appAccess.CurrentProject.AllForms
On Error GoTo NextForm
appAccess.DoCmd.OpenForm obj.Name, acDesign
If appAccess.Forms(obj.Name).HasModule = True Then
FixModule appAccess.Forms(obj.Name).Module
End If
appAccess.DoCmd.Close acForm, obj.Name, acSaveYes
NextForm:
Next obj
For Each obj In appAccess.CurrentProject.AllReports
On Error GoTo NextReport
appAccess.DoCmd.OpenReport obj.Name, acDesign
If appAccess.Reports(obj.Name).HasModule = True Then
FixModule appAccess.Reports(obj.Name).Module
End If
appAccess.DoCmd.Close acReport, obj.Name, acSaveYes
NextReport:
Next obj
On Error GoTo 0
appAccess.CloseCurrentDatabase
appAccess.Quit
Set appAccess = Nothing
Shell "notepad.exe """ & CurrentProject.Path & "\errhandling.txt"""
End Sub
Public Sub FixModule(mdl As Module)
Dim lngCount As Long
Dim lngCountDecl As Long
Dim lngI As Long
Dim strProcName As String
Dim strInsert As String
Dim astrProcNames() As String
Dim aboolProcErrHandling() As Boolean
Dim intI As Integer
Dim i As Integer
Dim strMsg As String
Dim strComment As String
Dim lngR As Long
Dim fs As Object, txtfile As Object
If mdl.Type = 8 Then
'module type 8 is a Class Module.
'we'll just let the calling procedure throw the error
'rather than dealing with error handling in the class
'so we'll exit the sub without doing anything
Exit Sub
End If
lngCount = mdl.CountOfLines
lngCountDecl = mdl.CountOfDeclarationLines
strProcName = mdl.ProcOfLine(lngCountDecl + 1, lngR)
intI = 0
ReDim Preserve astrProcNames(intI)
ReDim Preserve aboolProcErrHandling(intI)
astrProcNames(intI) = strProcName
aboolProcErrHandling(intI) = False
For lngI = lngCountDecl + 1 To lngCount
If InStr(mdl.Lines(lngI, 1), "On Error") > 0 Then aboolProcErrHandling(intI) = True
If strProcName <> mdl.ProcOfLine(lngI, lngR) Then
intI = intI + 1
strProcName = mdl.ProcOfLine(lngI, lngR)
ReDim Preserve astrProcNames(intI)
ReDim Preserve aboolProcErrHandling(intI)
astrProcNames(intI) = strProcName
aboolProcErrHandling(intI) = False
End If
Next lngI
strMsg = "Procedures in module '" & mdl.Name & "': " & vbCrLf & vbCrLf
For intI = 0 To UBound(astrProcNames)
If astrProcNames(intI) = "InputBoxDK" Then
Stop
End If
strMsg = strMsg & astrProcNames(intI) & "; " & aboolProcErrHandling(intI) & vbCrL
If aboolProcErrHandling(intI) = False And Not Nz(astrProcNames(intI)) = "" Then
Do Until Not Replace(mdl.Lines(mdl.ProcStartLine(astrProcNames(intI), lngR), 1), " ", "") = ""
mdl.DeleteLines mdl.ProcStartLine(astrProcNames(intI), lngR), 1
Loop
'take out any initial comments blocks, store them to put back after inserting "On Error"
strComment = ""
Do Until Not InStr(Replace(mdl.Lines(mdl.ProcStartLine(astrProcNames(intI), lngR), 1), " ", ""), "'") = 1
strComment = strComment & mdl.Lines(mdl.ProcStartLine(astrProcNames(intI), lngR), 1) & vbCrLf
mdl.DeleteLines mdl.ProcStartLine(astrProcNames(intI), lngR), 1
Loop
'Find the first line after the procedure start line (for line continuation (_) handling)
i = 0
Do While InStr(Replace(mdl.Lines(mdl.ProcStartLine(astrProcNames(intI), lngR) + i, 1), " ", ""), "_") = Len(Replace(mdl.Lines(mdl.ProcStartLine(astrProcNames(intI), lngR) + i, 1), " ", ""))
i = i + 1
Loop
mdl.InsertLines mdl.ProcStartLine(astrProcNames(intI), lngR) + i + 1, "On Error Goto Err_Handler"
strInsert = "Exit_Err:" & vbCrLf & _
vbTab & "Exit " & IIf(InStr(mdl.Lines(mdl.ProcStartLine(astrProcNames(intI), lngR), 1), "Function") > 0, "Function", "Sub") & vbCrLf & _
"Err_Handler:" & vbCrLf & _
vbTab & "psubGlobalErrHandler """ & astrProcNames(intI) & """, """ & mdl.Name & """, Err.Number, Err.Description" & vbCrLf & _
vbTab & "Resume Exit_Err"
If Not intI = UBound(astrProcNames) Then
mdl.InsertLines mdl.ProcStartLine(astrProcNames(intI + 1), lngR) - 1, strInsert
Else
'remove any trailing spaces or comments in the module before inserting the error handling block
Do Until Not mdl.Lines(mdl.CountOfLines, 1) = "" And Not InStr(Replace(mdl.Lines(mdl.CountOfLines, 1), " ", ""), "'") = 1
mdl.DeleteLines mdl.CountOfLines, 1
Loop
mdl.InsertLines mdl.CountOfLines, strInsert
End If
'put the intitial comment block back in
mdl.InsertLines mdl.ProcStartLine(astrProcNames(intI), lngR), strComment
End If
Next intI
Set fs = CreateObject("Scripting.FileSystemObject")
Set txtfile = fs.OpenTextFile(CurrentProject.Path & "\errhandling.txt", 8, True)
txtfile.WriteLine strMsg
txtfile.Close
Set txtfile = Nothing
Set fs = Nothing
End Sub
UPDATE: After help from some of my fellow experts at bytes.com, I now have a function that finds and converts the macros in each form and report. I had hoped for something as elegant as the intrinsic property "HasModule" for the form, but instead we have to check each form and control property for macros. You'll have to babysit the code as it runs to click on the conversion message, but it does the job. Add the following line in the InsertErrorHandling procedure just below the line:appAccess.DoCmd.OpenForm obj.Name, acDesign:
ConvertFormMacros appAccess.Forms(obj.Name)
and in the corresponding location for reports:
ConvertReportMacros appAccess.Reports(obj.Name)
It is very important to pass the form or report with
obj.Name, rather than obj itself; obj is dimensioned as an "object" data type, so the properties intrinsic to forms and reports are not available to it. By passing the form or report with obj's Name property to the functions, we're able to access all of the properties that we need to check.Insert these functions into your module, and then run it against a database with macros to see it convert the macros to VBA and then add the global error handling routine to them.
Public Function ConvertReportMacros(r As Report)
Dim c As Control
Dim p As Property
On Error Resume Next
For Each p In r.Properties
If IsEvent(p.Name) Then
If Not (Nz(p.Value) = "[Event Procedure]" Or Nz(p.Value) Like "=*" Or Nz(p.Value) = "") Then
r.Application.DoCmd.RunCommand acCmdConvertMacrosToVisualBasic
End If
End If
Next p
For Each c In r.Controls
For Each p In c.Properties
If IsEvent(p.Name) Then
If Not (Nz(p.Value) = "[Event Procedure]" Or Nz(p.Value) Like "=*" Or Nz(p.Value) = "") Then
r.Application.DoCmd.RunCommand acCmdConvertMacrosToVisualBasic
End If
End If
Next p
Next c
End Function
Public Function ConvertFormMacros(f As Form)
Dim c As Control
Dim p As Property
On Error Resume Next
For Each p In f.Properties
If IsEvent(p.Name) Then
If Not (Nz(p.Value) = "[Event Procedure]" Or Nz(p.Value) Like "=*" Or Nz(p.Value) = "") Then
f.Application.DoCmd.RunCommand acCmdConvertMacrosToVisualBasic
End If
End If
Next p
For Each c In f.Controls
For Each p In c.Properties
If IsEvent(p.Name) Then
If Not (Nz(p.Value) = "[Event Procedure]" Or Nz(p.Value) Like "=*" Or Nz(p.Value) = "") Then
f.Application.DoCmd.RunCommand acCmdConvertMacrosToVisualBasic
End If
End If
Next p
Next c
End Function
Public Function IsEvent(strProperty As String)
Select Case strProperty
Case "OnActivate", "AfterDelConfirm", "AfterInsert", "AfterUpdate", "OnApplyFilter", "BeforeDelConfirm", _
"BeforeInsert", "BeforeUpdate", "OnChange", "OnClick", "OnClose", "OnCurrent", "OnDblClick", "OnDeactivate", _
"OnDelete", "OnDirty", "OnEnter", "OnError", "OnExit", "OnFilter", "OnFormat", "OnGotFocus", "OnKeyDown", _
"OnKeyPress", "OnKeyUp", "OnLoad", "OnLostFocus", "OnMouseDown", "OnMouseMove", "OnMouseUp", "OnNoData", _
"OnNotInList", "OnOpen", "OnPage", "OnPrint", "OnResize", "OnRetreat", "OnTimer", "OnUnload", "OnUpdated"
IsEvent = True
Case Else
IsEvent = False
End Select
End Function
No comments:
Post a Comment