I have created an error handler for a larger program that will email me when an error occurs which includes what line the error is happening on and the code for the whole function/sub that it happen in.
The issue is that this code relies completely on having line numbers for every line in the code. I want to recreate this function without having to revamp line numbers whenever I make a change.
Does anyone have any suggestions? Here is what I am using now:
Public Sub EmailErrror(e As ErrObject, eLine As Integer, eSheet As String)
Dim OutApp As Outlook.Application
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = Outlook.Application
Set OutMail = OutApp.CreateItem(0)
Dim eProc, eCode, eProcCode, eProcStart As Long, eProcLines As Long, eCodeSRow As Long, eCodeSCol As Long, eCodeERow As Long, eCodeECol As Long
ThisWorkbook.VBProject.VBComponents(eSheet).CodeModule.Find eLine & " ", eCodeSRow, eCodeSCol, eCodeERow, eCodeECol
eCode = ThisWorkbook.VBProject.VBComponents(eSheet).CodeModule.Lines(eCodeSRow, Abs(eCodeERow - eCodeSRow) + 1) 'mdl.Lines(lngSLine, Abs(lngELine - lngSLine) + 1)
eProc = ThisWorkbook.VBProject.VBComponents(eSheet).CodeModule.ProcOfLine(eCodeSRow, 0)
eProcStart = ThisWorkbook.VBProject.VBComponents(eSheet).CodeModule.ProcStartLine(eProc, 0)
eProcLines = ThisWorkbook.VBProject.VBComponents(eSheet).CodeModule.ProcCountLines(eProc, 0)
eProcCode = ThisWorkbook.VBProject.VBComponents(eSheet).CodeModule.Lines(eProcStart, eProcLines)
With OutMail
.To = "ME"
.CC = "My boss"
.BCC = ""
.Subject = "Error in " & ThisWorkbook.Name & "!" & eSheet & " on " & eProc
.HTMLBody = "Error in " & ThisWorkbook.Name & " on " & eProc & " line " & eLine & "<BR><BR>"
.HTMLBody = .HTMLBody & "Line Error Occured:<BR><BR>" & eCode
.HTMLBody = .HTMLBody & "<BR><BR>Error: " & e.Number & " - " & e.Description
.HTMLBody = .HTMLBody & "<BR><BR><HR>Full Procedure Code:<BR><BR>" & Replace(Replace(eProcCode, vbCrLf, "<br>"), " ", " ")
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Email error information given non-unique error numbers
"The issue is that this code relies completely on having line numbers for every line in the code.
I want to recreate this function without having to revamp line numbers whenever I make a change."
As you don't want to renumber all the other procedures of the same code module whenever making a change and consequently allow number doublettes at the same time, you'll have to change the current logic:
Instead of searching a (1) unique error line number within a given code module, (2) getting the line number in the code module
and (3) the presumable code line which raised the error you have to procede as follows:
- search the start line of an identified procedure,
- search the error line number thereafter,
- get the error raising code line via a helper function returning a results array
info.
Pre-conditions to get the error raising code line
-This code assumes the following two conditions after activating the error handler's goto line label, e.g. by On Error goto OOPS
-i.) Define module:
assign the actual module name to an identical constant name MYMODULE in the declaration head of each code module:
Private Const MYMODULE$ = "Module1" ' << change to actual module name
-ii.) Define procedure: each procedure with an error handler defines its own procedure name via Err.Source assignment:
OOPS: Err.Source = "MyProcedure" ' << change OOPS: to your default error line label
Then you can always use the following INVARIABLE calling code of EmailErrorin the following line:
EmailError Err, Erl, MYMODULE ' invariable call
So a module could start as follows:
Option Explicit ' declaration head of code module
Private Const MYMODULE$ = "Module1" ' (i.) change to actual module name
Sub nonsens2()
10 Dim x ' 30 mustn't be found here
20 On Error GoTo OOPS ' On Error Statement defining error line label
30 x = 20 / 0 ' error raising code line
done: Exit Sub
OOPS: Err.Source = "nonsens2" ' (ii.) Err.Source assignment of current procedure
EmailError Err, Erl, MYMODULE ' call main procedure to get error info
End Sub
Main procedure EmailError
The procedure EmailError (as close as possible to your OP) is called in order to email information about an ocurring error and
relies on enumerated error lines as identifiers.
As you don't want to renumber all lines in each code module, you use (unique) line numbers only within the same procedure.
Consequently the same error line number would be found repeatedly and you have to narrow the search field to a given procedure within a given module.
Besides the fact that line numbering has a general integer limitation - ending at (2 ^ 15) -1 = 32767 (due to its older programming days in Basic), you should consider other important pecularities.
This approach doesn't pretend to cover all possible variants, but you can study a lot of interesting examples at Find all numbered lines in VBE modules via pattern search.
You should also provide for line continuation indicated by the underline character "_" when getting an error line;
this demo only provides for a single line break, (could easily be adapted for more :-)
(Don't forget the reference to Microsoft Visual Basic for Applications Extensibility 5.3)
Sub EmailError(e As ErrObject, ByVal eLine As Integer, eSheet$)
' Purpose: email ocurring error based on enumerated error lines (unique only WITHIN same procedure)
Dim OutApp As Outlook.Application
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = Outlook.Application
Set OutMail = OutApp.CreateItem(0)
Dim vERR: vERR = Split(e.Source, " ")
Dim eProcName$: eProcName = IIf(UBound(vERR) = 0, vERR(LBound(vERR)), vERR(UBound(vERR)))
Dim eProcType$: eProcType = IIf(UBound(vERR) = 0, "?", vERR(LBound(vERR)))
If eProcType = "Private" Or eProcType = "Public" Then eProcType = vERR(1)
Dim comp As Object
Set comp = ThisWorkbook.VBProject.VBComponents(eSheet)
'Get results
Dim info
Const EPROC = 0, ECODE = 1, EERL = 2, EPROCSTART = 3, EPROCLINES = 4, ELOCATED = 5
info = getErrLine(comp, eProcName, eLine) ' << call helper function to get code line information
With OutMail
.To = "ME"
.CC = "My boss"
.BCC = ""
.Subject = "Error in " & ThisWorkbook.Name & IIf(comp.Type = 100, "!" & eSheet & " in procedure " & Split(info(EPROC), ".")(1), " in procedure " & info(EPROC))
.HTMLBody = "Error in " & ThisWorkbook.Name & " in procedure " & info(EPROC) & " at ERL line " & info(EERL) & "<br/>"
.HTMLBody = .HTMLBody & "(Procedure """ & Split(info(EPROC), ".")(1) & """ starts at line " & info(EPROCSTART) & " and counts " & info(EPROCLINES) & " lines)<br/><br/>"
.HTMLBody = .HTMLBody & "Module Line Error Occured:<br/><br/>" & info(ELOCATED)
.HTMLBody = .HTMLBody & "<br/><br/>Error: " & e.Number & " - " & e.Description
.HTMLBody = .HTMLBody & "<br/><br/><hr/>Full Procedure Code:<br/><br/>" & Replace(Replace(info(ECODE), vbCrLf, "<br/>"), " ", " ")
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Helper function getErrLine()
This helper function is called by the above main procedure EMailError and collects the necessary code line information of the error raising procedure in an array. Side note: this code demonstrates a possible way, but doesn't want to win a beauty contest
Function getErrLine(comp As Object, ByVal eProcName$, ByVal eLine As Integer) As Variant()
' Purpose: return code line information of an error raising procedure in an array
' Note: called by above error handler procedure EMailError
' Author: T.M. (https://stackoverflow.com/users/6460297/t-m)
Const EPROC = 0, ECODE = 1, EERL = 2, EPROCSTART = 3, EPROCLINES = 4, ELOCATED = 5, TEST = 6
Dim i&, FoundProc$, eCodeLine$, eCodeSRow&, eCodeSCol&, eCodeERow&, eCodeECol&, bfound As Boolean
Dim a: ReDim a(0 To 6)
If Len(Trim(eProcName)) = 0 Then Exit Function
With comp.CodeModule
a(EPROC) = .Name & "."
' Step 1 - check if correct procedure has been found and get connected data
Do While True
eCodeSRow = eCodeERow + 1
If eCodeERow > .CountOfLines Then
eCodeERow = 0: Exit Function
End If
' locate indicated procedure
.Find eProcName, eCodeSRow, 0, eCodeERow, 0
FoundProc = .ProcOfLine(eCodeSRow, 0)
' Debug.Print i & ". " & eProcName & "? -> " & eCodeERow, """" & eProc & """"
If eCodeERow = 0 Then
Exit Do
ElseIf FoundProc = eProcName Then ' found procedure equals indicated procedure
bfound = True: a(EPROC) = a(EPROC) & FoundProc: Exit Do
End If
Loop
If Not bfound Then
a(EPROC) = "#Wrong procedure name - nothing found!"
' Step 2 - search indicated Error line and collect connected line infos
Else
Do While True
eCodeSRow = eCodeERow + 1
If eCodeERow > .CountOfLines Then
eCodeERow = 0: Exit Function
End If
' locate indicated ERL
.Find eLine & " ", eCodeSRow, 0, eCodeERow, 0
FoundProc = .ProcOfLine(eCodeSRow, 0)
' Debug.Print i & ". " & eProcName & "? -> " & eCodeERow, """" & eProc & """"
If eCodeERow = 0 Then Exit Do
If FoundProc = eProcName Then
' usually a line number is followed by a space, but
' can also be followed by an instruction separator ":"
If Split(Replace(.Lines(eCodeERow, 1), ":", ""), " ")(0) = eLine Then bfound = True: Exit Do
End If
Loop
If Not bfound Then
a(EERL) = "Indicated ERL " & eLine & " doesn't exist."
Else ' search indicated error line
eCodeLine = .Lines(eCodeERow, 1)
If Right(eCodeLine, 1) = "_" Then eCodeLine = .Lines(eCodeERow, 2)
a(ECODE) = eCodeLine ' code
a(EERL) = eLine ' ERL
a(EPROCSTART) = .ProcStartLine(FoundProc, 0) ' eProcStart
a(EPROCLINES) = .ProcCountLines(FoundProc, 0) ' eProcLines
a(ELOCATED) = eCodeERow ' module line raising error
' a(TEST) = .Lines(eCodeERow, 1) ' eCode - 1 line only
End If
End If
End With
' return all array information including error line in item 1
getErrLine = a
End Function
