发生错误时通过电子邮件发送给我的VBA错误处理程序 [英] VBA Error Handler that emails me when errors occur

查看：120
本文介绍了发生错误时通过电子邮件发送给我的VBA错误处理程序的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我为一个较大的程序创建了一个错误处理程序，该程序将在发生错误时向我发送电子邮件，其中包括发生错误的行以及发生该错误的整个函数/子代码.

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

推荐答案

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

问题是该代码完全依赖于代码中每行的行号. 我想重新创建此功能，而不必在每次更改时都修改行号."

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

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

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:

而不是在给定的代码模块中搜索(1)唯一错误行号，(2)在代码模块中获取行号 和(3)导致错误的可推定代码行，您必须按以下步骤进行操作:

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. 搜索已识别过程的开始行，
  2. 此后搜索错误行号，
  3. 通过返回结果数组info的帮助器函数获取引发错误的代码行.
  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.

获取错误提示代码行的前提条件

-激活错误处理程序的goto行标签后，此代码假定以下两个条件，例如通过On Error goto OOPS

-This code assumes the following two conditions after activating the error handler's goto line label, e.g. by On Error goto OOPS

- i.)定义模块: 在每个代码模块的声明头中，将实际的模块名称分配给相同的常量名称MYMODULE :

-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.)定义过程:每个带有错误处理程序的过程都通过错误源分配来定义自己的过程名称:

-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

然后，您始终可以在以下行中使用EmailError的以下INVARIABLE调用代码:

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

主要过程EmailError

Main procedure EmailError

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

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.

行编号具有一般的整数限制的事实-以(2 ^ 15)-1 = 32767结尾(由于其在Basic中的编程天数较长) ，则应考虑其他重要的俗语. 这种方法并不假装涵盖所有可能的变体，但是您可以在行继续； 该演示仅提供一个换行符，(可以很容易地适用于更多:-)

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 :-)

(不要忘记对 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()

Helper function getErrLine()

此辅助函数由上述主过程EMailError调用，并在数组中收集错误产生过程的必要代码行信息. 旁注:此代码演示了一种可能的方法，但不想赢得选美比赛

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

这篇关于发生错误时通过电子邮件发送给我的VBA错误处理程序的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文
相关文章
其他开发最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆