我为一个较大的程序创建了一个错误处理程序，该程序将在发生错误时向我发送电子邮件，其中包括发生错误的行以及发生该错误的整个函数/子代码。
问题在于此代码完全依赖于代码中每行的行号。我想重新创建此功能，而不必在每次更改时都修改行号。
有人有什么建议吗？这是我现在正在使用的：
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
答案 0 :(得分：1)
电子邮件错误信息已给出非唯一错误编号
“问题在于此代码完全依赖于代码中每行的行号。 我想重新创建此功能，而不必在每次更改时都修改行号。”
由于您不想每次更改时都对同一代码模块的所有其他过程重新编号，因此同时允许 number doublettes ，因此，您必须更改当前逻辑：
不是在给定的代码模块中搜索（1）唯一错误行号，而是（2）在代码模块中获取行号 和（3）导致错误的可推定代码行，您必须按以下步骤进行操作：
info的帮助器函数获取引发错误的代码行。获取错误提示代码行的前提条件
-激活错误处理程序的goto行标签后，此代码假设以下两个条件，例如由On Error goto OOPS
- i。）定义模块：
在每个代码模块的声明头中，将实际的模块名称分配给相同的常量名称MYMODULE ：
Private Const MYMODULE$ = "Module1" ' << change to actual module name
- ii。）定义过程：每个带有错误处理程序的过程都通过错误源分配来定义自己的过程名称：
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