Получить имя текущей функции VBA - PullRequest
30 голосов
/ 25 сентября 2010

Для кода обработки ошибок, я хотел бы получить имя текущей функции VBA (или подчиненной), в которой произошла ошибка. Кто-нибудь знает, как это можно сделать?

[ПРАВИТЬ] Спасибо всемЯ надеялся, что существует недокументированный трюк для самоопределения функции, но этого явно не существует.Думаю, я останусь с моим текущим кодом:

Option Compare Database: Option Explicit: Const cMODULE$ = "basMisc"

Public Function gfMisc_SomeFunction$(target$)
On Error GoTo err_handler: Const cPROC$ = "gfMisc_SomeFunction"
    ...
exit_handler:
    ....
    Exit Function
err_handler:
    Call gfLog_Error(cMODULE, cPROC, err, err.Description)
    Resume exit_handler
End Function

Ответы [ 10 ]

15 голосов
/ 25 сентября 2010

Текущее имя функции получить нечего, но вы можете создать довольно легкую систему трассировки, используя тот факт, что время жизни объекта VBA является детерминированным.Например, у вас может быть класс с именем «Tracer» с этим кодом:

Private proc_ As String

Public Sub init(proc As String)
    proc_ = proc
End Sub

Private Sub Class_Terminate()
    If Err.Number <> 0 Then
        Debug.Print "unhandled error in " & proc_
    End If
End Sub

, а затем использовать этот класс в процедурах, таких как:

Public Sub sub1()
    Dim t As Tracer: Set t = New Tracer
    Call t.init("sub1")

    On Error GoTo EH

    Call sub2

    Exit Sub

EH:
    Debug.Print "handled error"
    Call Err.Clear
End Sub

Public Sub sub2()
    Dim t As Tracer: Set t = New Tracer
    Call t.init("sub2")

    Call Err.Raise(4242)
End Sub

Если вы запустите «sub1»,вы должны получить следующие выходные данные:

unhandled error in sub2
handled error

, потому что ваш экземпляр Tracer в 'sub2' был детерминированно уничтожен, когда ошибка вызвала выход из подпрограммы.

Этот общий паттерн часто встречается вC ++, под названием «RAII», но он прекрасно работает и в VBA (кроме общего раздражения от использования классов).

РЕДАКТИРОВАТЬ:

Чтобы ответить на комментарий Дэвида Фентона, что этоОтносительно сложное решение простой проблемы, я не думаю, что проблема на самом деле настолько проста!

Я считаю само собой разумеющимся, что мы все согласны с тем, что мы не хотим давать каждую процедуру внаша программа VBA имеет собственный обработчик ошибок.(См. Мои рассуждения здесь: Ошибка VBA "Bubble Up" )

Если некоторые внутренние подпрограммы не имеют своих собственных обработчиков ошибок, тогда, когда мы делаем ловимошибка, все, что мы знаем, это то, что произошло в подпрограмме с обработчиком ошибок, который сработал, или в подпрограмме где-то глубже в стеке вызовов.Так что проблема, насколько я понимаю, на самом деле заключается в отслеживании выполнения нашей программы.Отслеживание рутинного входа легко, конечно.Но отслеживание выхода действительно может быть довольно сложным.Например, может быть ошибка, которая возникает!

Подход RAII позволяет нам использовать естественное поведение управления жизненным циклом объектов VBA, чтобы распознать, когда мы вышли из процедуры, будь то «Выход», «Конец» или ошибка.Мой игрушечный пример просто предназначен для иллюстрации концепции.Настоящий «трассировщик» в моей собственной небольшой платформе VBA, безусловно, более сложен, но также делает больше:

Private Sub Class_Terminate()
    If unhandledErr_() Then
        Call debugTraceException(callID_, "Err unhandled on exit: " & fmtCurrentErr())
    End If

    If sendEntryExit_ Then
        Select Case exitTraceStatus_
            Case EXIT_UNTRACED
                Call debugTraceExitImplicit(callID_)
            Case EXIT_NO_RETVAL
                Call debugTraceExitExplicit(callID_)
            Case EXIT_WITH_RETVAL
                Call debugTraceExitExplicit(callID_, retval_)
            Case Else
                Call debugBadAssumption(callID_, "unrecognized exit trace status")
        End Select
    End If
End Sub

Но использовать его все же довольно просто, и он стоит меньше шаблонного, чем «EH» в каждой программе"подходите в любом случае:

Public Function apply(functID As String, seqOfArgs)
    Const PROC As String = "apply"
    Dim dbg As FW_Dbg: Set dbg = mkDbg(MODL_, PROC, functID, seqOfArgs)

...

Автоматически сгенерировать шаблон очень просто, хотя я на самом деле набираю его, а затем автоматически проверяю, совпадают ли имена подпрограмм / аргументов как часть моих тестов.

6 голосов
/ 25 сентября 2010

Я использую кнопку обработчика ошибок в бесплатном MZTools для VBA. Он автоматически добавляет строки кода вместе с именем sub / function. Теперь, если вы переименуете суб / функцию, вы должны помнить, чтобы изменить код.

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

3 голосов
/ 25 сентября 2010

VBA не имеет встроенной трассировки стека, к которой вы можете получить программный доступ. Вы должны были бы создать свой собственный стек и вставить / вытолкнуть его, чтобы сделать что-то подобное. В противном случае вам нужно будет жестко закодировать имена ваших функций / вложенных имен в код.

3 голосов
/ 25 сентября 2010

Не использует какой-либо встроенный способ VBA. Лучшее, что вы сможете сделать, это повторить себя, жестко закодировав имя метода как постоянную или обычную переменную уровня метода.

Const METHOD_NAME = "GetCustomer"

 On Error Goto ErrHandler:
 ' Code

ErrHandler:
   MsgBox "Err in " & METHOD_NAME

Вы можете найти что-нибудь полезное в MZ Tools для VBA . Это надстройка разработчика для семейства языков VB. Автор MVP.

2 голосов
/ 10 февраля 2019

Код Шона Хендрикса совсем не плохой.Я немного его улучшил:

Public Function AddErrorCode(modName As String)
    Dim VBComp As Object
    Dim VarVBCLine As Long

    Set VBComp = Application.VBE.ActiveVBProject.VBComponents(modName)

    For VarVBCLine = 1 To VBComp.CodeModule.CountOfLines + 1000
        If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*Function *") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine + 1, 1) Like "On Error GoTo *") Then
                     VBComp.CodeModule.InsertLines VarVBCLine + 1, "On Error GoTo ErrHandler_"
                     VBComp.CodeModule.InsertLines VarVBCLine + 2, "    Dim VarThisName as String"
                     VBComp.CodeModule.InsertLines VarVBCLine + 3, "    VarThisName = """ & Trim(Mid(VBComp.CodeModule.Lines(VarVBCLine, 1), InStr(1, VBComp.CodeModule.Lines(VarVBCLine, 1), "Function") + Len("Function"), Len(VBComp.CodeModule.Lines(VarVBCLine, 1)))) & """"
                    VarVBCLine = VarVBCLine + 4
            End If
        End If
         If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*End Function*") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine - 1, 1) Like "*Resume '*") And Not (UCase(VBComp.CodeModule.Lines(VarVBCLine - 1, 1)) Like UCase("*Err.Raise*")) Then
                VBComp.CodeModule.InsertLines VarVBCLine, "ExitProc_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 1, "    Exit Function"
                VBComp.CodeModule.InsertLines VarVBCLine + 2, "ErrHandler_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 3, "    Call LogError(Err, Me.Name, VarThisName)"
                VBComp.CodeModule.InsertLines VarVBCLine + 4, "    Resume ExitProc_"
                VBComp.CodeModule.InsertLines VarVBCLine + 5, "    Resume ' use for debugging"
                VarVBCLine = VarVBCLine + 6
            End If
        End If

        If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*Private Sub *") Or UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*Public Sub *") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine + 1, 1) Like "On Error GoTo *") Then
                     VBComp.CodeModule.InsertLines VarVBCLine + 1, "On Error GoTo ErrHandler_"
                     VBComp.CodeModule.InsertLines VarVBCLine + 2, "    Dim VarThisName as String"
                     VBComp.CodeModule.InsertLines VarVBCLine + 3, "    VarThisName = """ & Trim(Mid(VBComp.CodeModule.Lines(VarVBCLine, 1), InStr(1, VBComp.CodeModule.Lines(VarVBCLine, 1), "Sub") + Len("Sub"), Len(VBComp.CodeModule.Lines(VarVBCLine, 1)))) & """"
                    VarVBCLine = VarVBCLine + 4
            End If
        End If
         If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*End Sub*") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine - 1, 1) Like "*Resume '*") And Not (UCase(VBComp.CodeModule.Lines(VarVBCLine - 1, 1)) Like UCase("*Err.Raise*")) Then
                VBComp.CodeModule.InsertLines VarVBCLine, "ExitProc_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 1, "    Exit Sub"
                VBComp.CodeModule.InsertLines VarVBCLine + 2, "ErrHandler_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 3, "    Call LogError(Err, Me.Name, VarThisName)"
                VBComp.CodeModule.InsertLines VarVBCLine + 4, "    Resume ExitProc_"
                VBComp.CodeModule.InsertLines VarVBCLine + 5, "    Resume ' use for debugging"
                'VBComp.CodeModule.DeleteLines VarVBCLine + 5, 1
                'VBComp.CodeModule.ReplaceLine VarVBCLine + 5, "    Resume ' replaced"
                VarVBCLine = VarVBCLine + 6
            End If
        End If

    Next VarVBCLine

End Function

Вы можете поместить его в отдельный модуль и вызвать его так:

AddErrorCode "Form_MyForm" 

в окне Immediate.Он изменит код вашей формы с этого:

Private Sub Command1_Click()

    Call DoIt

End Sub

на этот во всех процедурах MyForm.

Private Sub Command1_Click()
On Error GoTo ErrHandler_
   Dim VarThisNameAs String
   VarThisName = "Command1_Click()"

        Call DoIt

ExitProc_:
    Exit Sub
ErrHandler_:
    Call LogError(Err, Me.Name, VarThisName)
    Resume ExitProc_
    Resume ' use for debugging
End Sub

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

Public Sub LogError(ByVal objError As ErrObject, PasModuleName As String, Optional PasFunctionName As String = "")
    On Error GoTo ErrHandler_
    Dim sql As String
    ' insert the values into a file or DB here
    MsgBox "Error " & Err.Number & Switch(PasFunctionName <> "", " in " & PasFunctionName) & vbCrLf & " (" & Err.Description & ") ", vbCritical, Application.VBE.ActiveVBProject.Name
Exit_:
    Exit Sub
ErrHandler_:
    MsgBox "Error in LogError function " & Err.Number
    Resume Exit_
    Resume ' use for debugging
End Sub
2 голосов
/ 26 июня 2013

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

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

ПРИМЕЧАНИЕ: я никоим образом не связан с продуктом, за исключением того, что я чрезвычайно довольный пользователь.

1 голос
/ 16 июля 2015

Это работает для меня. Я в 2010 году.

ErrorHandler:
    Dim procName As String
    procName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
    MyErrorHandler err, Me.Name, getUserID(), procName
    Resume Exithere
0 голосов
/ 29 июня 2019

Решение Марка Ронолло работает как шарм.

Мне нужно было извлечь все имена процедур из всех модулей для целей документации, поэтому я взял его коди адаптировал его к функции ниже, которая обнаруживает все имена процедур во всем моем коде, включая формы и модули, а затем сохраняет его в таблице в моем файле Access с именем VBAProcedures (таблица просто имеет уникальный ключ, столбец с именем[Module] и столбец с именем [Procedure]. Это сэкономило мне часы ручной работы!

    Sub GetAllVBAProcedures()
    Dim Message As String, Query As String, tmpModule As String
    Dim MaxLines As Integer, tmpLine As Integer, i As Integer
    MaxLines = 4208
    Dim obj As AccessObject, db As Object
    Query = "delete from VBAProcedures"
    CurrentDb.Execute Query
    For i = 1 To Application.VBE.CodePanes.Count
        tmpModule = ""
        For tmpLine = 1 To MaxLines
            Message = Application.VBE.CodePanes(i).CodeModule.ProcOfLine(tmpLine, 0)
            If Message <> tmpModule And Message <> "" Then
                tmpModule = Message
                Query = "insert into VBAProcedures ([Module], [Procedure]) values ('" & Application.VBE.CodePanes(i).CodeModule.Name & "', '" & tmpModule & "')"
                CurrentDb.Execute Query
            End If
        Next tmpLine
    Next i
    End Sub
0 голосов
/ 26 мая 2017

Серьезно?Почему разработчики продолжают решать одну и ту же проблему снова и снова?Отправьте get имя процедуры в объект Err, используя Err.Raise ...

Для параметра Source введите:

Me.Name & "." & Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)

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

0 голосов
/ 24 октября 2014

Код некрасив, но работает. В этом примере будет добавлен код обработки ошибок для каждой функции, которая также содержит строку с именем функции.

Function AddErrorCode()
    Set vbc = ThisWorkbook.VBProject.VBComponents("Module1")
    For VarVBCLine = 1 To vbc.codemodule.CountOfLines + 1000
        If UCase(vbc.codemodule.Lines(VarVBCLine, 1)) Like UCase("*Function *") And Not (UCase(vbc.codemodule.Lines(VarVBCLine, 1)) Like UCase("*Function FunctionReThrowError*")) Then
            If Not (vbc.codemodule.Lines(VarVBCLine + 1, 1) Like "*Dim VarFunctionName As String*") Then
                     vbc.codemodule.InsertLines VarVBCLine + 1, "Dim VarFunctionName as String"
                     vbc.codemodule.InsertLines VarVBCLine + 2, "VarFunctionName = """ & Trim(Mid(vbc.codemodule.Lines(VarVBCLine, 1), InStr(1, vbc.codemodule.Lines(VarVBCLine, 1), "Function") + Len("Function"), Len(vbc.codemodule.Lines(VarVBCLine, 1)))) & """"
                    VarVBCLine = VarVBCLine + 3
            End If
        End If
         If UCase(vbc.codemodule.Lines(VarVBCLine, 1)) Like UCase("*End Function*") Then
            If Not (vbc.codemodule.Lines(VarVBCLine - 1, 1) Like "*Call FunctionReThrowError(Err, VarFunctionName)*") And Not (UCase(vbc.codemodule.Lines(VarVBCLine - 1, 1)) Like UCase("*Err.Raise*")) Then
                vbc.codemodule.InsertLines VarVBCLine, "ErrHandler:"
                vbc.codemodule.InsertLines VarVBCLine + 1, "Call FunctionReThrowError(Err, VarFunctionName)"
                VarVBCLine = VarVBCLine + 2
            End If
        End If
    Next VarVBCLine
   If Not (vbc.codemodule.Lines(1, 1) Like "*Function FunctionReThrowError(ByVal objError As ErrObject, PasFunctionName)*") Then
        vbc.codemodule.InsertLines 1, "Function FunctionReThrowError(ByVal objError As ErrObject, PasFunctionName)"
        vbc.codemodule.InsertLines 2, "Debug.Print PasFunctionName & objError.Description"
        vbc.codemodule.InsertLines 3, "Err.Raise objError.Number, objError.Source, objError.Description, objError.HelpFile, objError.HelpContext"
        vbc.codemodule.InsertLines 4, "End Function"
    End If
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...