1. 技术文章
  2. VBA Error Handler that emails me when errors occur

VBA Error Handler that emails me when errors occur

由 |▌冷眼眸甩不掉的悲伤 提交于 2019-12-06 10:49:06

问题


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>"), " ", "&nbsp;")

        .Display
    End With

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

回答1:


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:

  1. search the start line of an identified procedure,
  2. search the error line number thereafter,
  3. 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/>"), " ", "&nbsp;")

    .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


来源：https://stackoverflow.com/questions/51895607/vba-error-handler-that-emails-me-when-errors-occur

标签
vba
excel-vba
parsing
error-handling
vbe
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!