发生错误时向我发送电子邮件的 VBA 错误处理程序

Question

我为一个更大的程序创建了一个错误处理程序，当错误发生时会通过电子邮件发送给我，其中包括错误发生在哪一行以及发生错误的整个函数/子的代码。

问题是这段代码完全依赖于代码中每一行的行号。我想重新创建此功能，而无需在进行更改时修改行号。

有没有人有什么建议？这是我现在使用的:

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

Answer 1

给定非唯一错误编号的电子邮件错误信息

"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."

由于您不想在进行更改时重新编号同一代码模块的所有其他过程并因此同时允许数字双拼，因此您必须更改当前逻辑:

而不是在给定的代码模块中搜索 (1) 唯一的错误行号，(2) 获取代码模块中的行号
(3) 引发错误的假定代码行，您必须按如下方式进行:

搜索已识别过程的起始行，

之后搜索错误行号，

通过返回结果数组 info 的辅助函数获取错误引发代码行.

获取错误引发代码行的先决条件

-此代码在激活错误处理程序的 goto 后假定以下两个条件行标签，例如通过 On Error goto OOPS
- i.) 定义模块:
分配实际 模块名称 到 相同的常量名 MYMODULE 在每个代码模块的声明头中:

 Private Const MYMODULE$ = "Module1"     ' << change to actual module name

- ii.) 定义程序:每个带有错误处理程序的过程都定义了自己的 程序名称 通过 Err.Source 分配 :

 OOPS: Err.Source = "MyProcedure"             ' << change OOPS:  to your default error line label

然后您可以随时使用以下 INVARIABLE 调用代码 EmailError在以下行中:

 EmailError Err, Erl, MYMODULE                   ' invariable call

所以一个模块可以如下开始:

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

主程序EmailError

程序 EmailError (尽可能靠近您的 OP)被调用以通过电子邮件发送有关发生错误的信息，并且
依赖 枚举错误行作为标识符。
由于您不想重新编号每个代码模块中的所有行，因此您只使用(唯一)行号 在同一程序内 .
因此，将重复找到相同的错误行号，并且您必须将搜索字段缩小到给定模块中的给定过程。

除了行号有一个通用的 整数限制 - 以 (2 ^ 15) -1 = 32767 结尾(由于它在 Basic 中的编程时间较早)，您应该考虑其他重要的 特性 .
这种方法并没有假装涵盖所有可能的变体，但您可以在 Find all numbered lines in VBE modules via pattern search 上研究很多有趣的示例。 .
您还应该提供 续行得到错误行时用下划线字符“_”表示；
这个演示只提供了一个换行符，(可以很容易地适应更多:-)

(不要忘记引用 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

辅助函数 getErrLine()

这个辅助函数被上面的主程序调用 EMailError并将错误引发过程的必要代码行信息收集到一个数组中。旁注:此代码演示了一种可能的方式，但不想赢得选美比赛

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