给定非唯一错误编号的电子邮件错误信息
“问题在于，这段代码完全依赖于代码中每一行的行号。
我想重新创建这个函数，而不必在每次进行更改时修改行号。”
因为您不想在每次进行更改时对同一代码模块的所有其他过程重新编号，从而允许数双峰同时，你必须改变当前的逻辑：
不是在给定代码模块中搜索 (1) 唯一的错误行号，而是 (2) 获取代码模块中的行号
(3) 可能引发错误的代码行，您必须按如下方式进行操作：
- 搜索已识别程序的起始行，
- 之后搜索错误行号，
- 通过返回结果数组的辅助函数获取错误引发代码行
info.
获取引发错误的代码行的先决条件
-此代码在激活错误处理程序后假设以下两个条件goto行标签，例如经过On Error goto OOPS
-i.) 定义模块：分配实际的模块名称 to an 相同的常量名称MYMODULE在每个代码模块的声明头中：
Private Const MYMODULE$ = "Module1" ' << change to actual module name
-ii.) 定义程序：每个带有错误处理程序的过程都定义了自己的程序名称 via 错误源分配:
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）被调用，以便通过电子邮件发送有关发生错误的信息，并且
依靠枚举错误行作为标识符。
因为你不想重新编号所有线路在每个代码模块中，您使用(unique)仅行号在同一程序内。
因此，将重复找到相同的错误行号，并且您必须将搜索字段缩小到给定模块内的给定过程。
除此之外，行编号有一个将军整数限制- 结束于 (2 ^ 15) -1 = 32767（由于其在 Basic 中的编程时间较早），您应该考虑其他重要的特点。
这种方法并不假装涵盖所有可能的变体，但您可以在以下位置研究许多有趣的示例通过模式搜索查找 VBE 模块中所有编号的行。
您还应该提供行延续获取错误行时用下划线“_”表示；
这个演示只提供了一个换行符，（可以很容易地适应更多:-)
（不要忘记参考Microsoft Visual Basic 应用程序扩展性 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
