给定非唯一错误编号的电子邮件错误信息
“问题在于这段代码完全依赖于代码中每一行的行号。
我想重新创建这个函数，而不必在每次进行更改时修改行号。”
由于您不想在进行更改时重新编号同一代码模块的所有其他过程并因此同时允许 number doublettes，因此您必须更改当前逻辑：
不是在给定代码模块中搜索 (1) 唯一的错误行号，而是 (2) 在代码模块中获取行号
(3) 引发错误的假定代码行，您必须按如下方式进行：
- 搜索已识别过程的起始行，
- 之后搜索错误行号，
- 通过返回结果数组
info 的帮助函数获取引发错误的代码行。
获取错误引发代码行的前提条件
-在激活错误处理程序的goto 行标签后，此代码假定以下两个条件，例如On Error goto OOPS
-i.) 定义模块：
将实际的模块名称分配给每个代码模块的声明头中的相同的常量名称MYMODULE：
Private Const MYMODULE$ = "Module1" ' << change to actual module name
-ii.) 定义过程： 每个带有错误处理程序的过程都通过 Err.Source 分配定义自己的过程名称： p>
OOPS: Err.Source = "MyProcedure" ' << change OOPS: to your default error line label
那么你总是可以在下面一行中使用EmailError的以下INVARIABLE调用代码：
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/>"), " ", " ")
.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