VBA Error Handler, который отправляет мне электронное письмо при возникновении ошибок

Question

VBA Error Handler, который отправляет мне электронное письмо при возникновении ошибок

Я создал обработчик ошибок для более крупной программы, которая будет отправлять мне электронное письмо при возникновении ошибки, которая включает в себя строку, в которой происходит ошибка, и код всей функции / подпрограммы, в которой она произошла.

Проблема заключается в том, что этот код полностью основан на наличии номеров строк для каждой строки в коде. Я хочу воссоздать эту функцию, не меняя номера строк каждый раз, когда я делаю изменения.

У кого-нибудь есть предложения? Вот что я использую сейчас:

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

2

vba excel-vba parsing error-handling vbe

Источник

user1008116 17 авг '18 в 12:36

1 ответ

Другие вопросы по тегам vba excel-vba parsing error-handling vbe

user6460297 27 авг '18 в 08:09 2018-08-27 08:09 · Answer 1 · 2018-08-27 08:09

Информация об ошибке электронной почты с учетом неуникальных номеров ошибок

"Проблема заключается в том, что этот код полностью полагается на наличие номеров строк для каждой строки в коде. Я хочу воссоздать эту функцию, не меняя номера строк всякий раз, когда я делаю изменения".

Поскольку вы не хотите перенумеровывать все остальные процедуры того же модуля кода при каждом изменении и, следовательно, одновременно разрешать число дублетов, вам придется изменить текущую логику:

Вместо поиска (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

Тогда вы всегда можете использовать следующий неизменный код вызова 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), вам следует учитывать и другие важные особенности. Этот подход не претендует на то, чтобы охватить все возможные варианты, но вы можете изучить множество интересных примеров в разделе Найти все пронумерованные строки в модулях 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/>"), " ", "&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