Как получить имя процедуры или функции во время выполнения?

Есть ли способ вернуть имя функции или процедуры во время выполнения?

В настоящее время я обрабатываю ошибки следующим образом:

Sub foo()
Const proc_name as string = "foo"
On Error GoTo ErrHandler

    ' do stuff

ExitSub:
    Exit Sub
ErrHandler:
    ErrModule.ShowMessageBox "ModuleName",proc_name
    Resume ExitSub
End Sub

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

Я знаю, что мне придется взаимодействовать с объектом VBIDE.CodeModule, чтобы найти его. Я немного выполнил метапрограммирование с помощью библиотеки Microsoft Visual Basic для расширения возможностей приложений, но я не добился успеха в этом во время выполнения. У меня нет моих предыдущих попыток, и прежде чем я выкапываю каблуки, чтобы попробовать это снова, я хочу знать, возможно ли это даже отдаленно.

Вещи, которые не будут работать

Использование встроенной библиотеки VBA для доступа к стеку вызовов. Этого не существует.
Реализация моего собственного стека вызовов путем нажатия и вызова имен процедур из массива при входе и выходе из каждого. Это по-прежнему требует, чтобы я передавал имя proc где-то еще как строку.
Третий инструмент, например vbWatchDog. Это действительно работает, но я не могу использовать сторонний инструмент для этого проекта.

Примечание

vbWatchdog, похоже, делает это, напрямую обращаясь к памяти ядра через вызовы API.

Ответы

Ответ 1

Я не совсем уверен, насколько это полезно...

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

Например

если вы можете избегать дублирования меток обработчика ошибок в разных subs/functions

не выполнять ⇩⇩⇩⇩⇩

Sub Main()
    On Error GoTo ErrHandler
    Debug.Print 1 / 0

ErrHandler:
    Debug.Print "handling error in Main"
    SubMain
End Sub

Sub SubMain()
    On Error GoTo ErrHandler
    Debug.Print 1 / 0

ErrHandler:
    Debug.Print "handling error in SubMain"
End Sub

то приведенный ниже код должен работать.

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

Примечание. Добавьте ссылки на Visual Basic for Applications Extensibility 5.3 через Инструменты → Ссылки в VBE

Sub Main()

    ' additionally, this is what else you should do:
    ' write a Boolean function that checks if there are no duplicate error handler labels
    ' this will ensure you don't get a wrong sub/fn name returned

    Foo
    Boo

End Sub


Function Foo()

    ' remember to set the label name (handlerLabel) in the handler
    ' each handler label should be unique to avoid errors
    On Error GoTo FooErr
    Cells(0, 1) = vbNullString ' cause error deliberately

FooErr:

    Dim handlerLabel$
    handlerLabel = "FooErr" ' or don't dim this and pass the errHandler name directly to the GetFnOrSubName function

    Debug.Print "Error occured in " & Application.VBE.ActiveCodePane.CodeModule.Name & ": " & GetFnOrSubName(handlerLabel)

End Function


Sub Boo()

    On Error GoTo BooErr
    Cells(0, 1) = vbNullString ' cause error deliberately

BooErr:

    Debug.Print "Error occured in " & Application.VBE.ActiveCodePane.CodeModule.Name & ": " & GetFnOrSubName("BooErr")

End Sub

' returns CodeModule reference needed in the GetFnOrSubName fn
Private Function GetCodeModule(codeModuleName As String) As VBIDE.CodeModule
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent

    Set VBProj = ThisWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(codeModuleName)

    Set GetCodeModule = VBComp.CodeModule
End Function

' returns the name of the sub where the error occured
Private Function GetFnOrSubName$(handlerLabel$)

    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule

    Set VBProj = ThisWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(Application.VBE.ActiveCodePane.CodeModule.Name)
    Set CodeMod = VBComp.CodeModule

    Dim code$
    code = CodeMod.Lines(1, CodeMod.CountOfLines)

    Dim handlerAt&
    handlerAt = InStr(1, code, handlerLabel, vbTextCompare)

    If handlerAt Then

        Dim isFunction&
        Dim isSub&

        isFunction = InStrRev(Mid$(code, 1, handlerAt), "Function", -1, vbTextCompare)
        isSub = InStrRev(Mid$(code, 1, handlerAt), "Sub", -1, vbTextCompare)

        If isFunction > isSub Then
            ' it a function
            GetFnOrSubName = Split(Mid$(code, isFunction, 40), "(")(0)
        Else
            ' it a sub
            GetFnOrSubName = Split(Mid$(code, isSub, 40), "(")(0)
        End If

    End If

End Function

Ответ 2

Я использую связанный node класс стека, завернутый в одноэлементный, созданный по всему миру (выполненный через атрибуты) класс CallStack. Это позволяет мне выполнять обработку ошибок, как предлагает Дэвид Земенс (каждый раз сохраняя имя процедуры):

Public Sub SomeFunc()
    On Error Goto ErrHandler
    CallStack.Push "MyClass.SomeFunc"


    '... some code ...

    CallStack.Pop()
    Exit Sub

ErrHandler:
    'Use some Ifs or a Select Case to handle expected errors
    GlobalErrHandler() 'Make a global error handler that logs the entire callstack to a file/the immediate window/a table in Access.

End Sub

Если бы это было полезно для обсуждения, я могу опубликовать связанный код. Класс CallStack имеет метод Peek, чтобы узнать, что является последней вызванной функцией, и функцию StackTrace, чтобы получить строковый вывод всего стека.

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

Ответ 3

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

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

Библиотека VBIDE не поддерживает процедуры хорошо, поэтому я завернул их в модуле класса с именем vbeProcedure.

' Class: vbeProcedure
' requires Microsoft Visual Basic for Applications Extensibility 5.3 library
' Author: Christopher J. McClellan
' Creative Commons Share Alike and Attribute license
'   http://creativecommons.org/licenses/by-sa/3.0/

Option Compare Database
Option Explicit

Private Const vbeProcedureError As Long = 3500

Private mParentModule As CodeModule
Private isParentModSet As Boolean
Private mName As String
Private isNameSet As Boolean

Public Property Get Name() As String
    If isNameSet Then
        Name = mName
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Let Name(ByVal vNewValue As String)
    If Not isNameSet Then
        mName = vNewValue
        isNameSet = True
    Else
        RaiseReadOnlyPropertyError
    End If
End Property

Public Property Get ParentModule() As CodeModule
    If isParentModSet Then
        Set ParentModule = mParentModule
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Let ParentModule(ByRef vNewValue As CodeModule)
    If Not isParentModSet Then
        Set mParentModule = vNewValue
        isParentModSet = True
    Else
        RaiseReadOnlyPropertyError
    End If
End Property

Public Property Get StartLine() As Long
    If isParentModSet And isNameSet Then
        StartLine = Me.ParentModule.ProcStartLine(Me.Name, vbext_pk_Proc)
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Get EndLine() As Long
    If isParentModSet And isNameSet Then
        EndLine = Me.StartLine + Me.CountOfLines
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Get CountOfLines() As Long
    If isParentModSet And isNameSet Then
        CountOfLines = Me.ParentModule.ProcCountLines(Me.Name, vbext_pk_Proc)
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Sub initialize(Name As String, codeMod As CodeModule)
    Me.Name = Name
    Me.ParentModule = codeMod
End Sub

Public Property Get Lines() As String
    If isParentModSet And isNameSet Then
        Lines = Me.ParentModule.Lines(Me.StartLine, Me.CountOfLines)
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Private Sub RaiseObjectNotIntializedError()
    Err.Raise vbObjectError + vbeProcedureError + 10, CurrentProject.Name & "." & TypeName(Me), "Object Not Initialized"
End Sub

Private Sub RaiseReadOnlyPropertyError()
    Err.Raise vbObjectError + vbeProcedureError + 20, CurrentProject.Name & "." & TypeName(Me), "Property is Read-Only after initialization"
End Sub

Затем я добавил функцию к моему модулю DevUtilities (что важно позже), чтобы создать объект vbeProcedure и вернуть их коллекцию.

Private Function getProcedures(codeMod As CodeModule) As Collection
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Returns collection of all vbeProcedures in a CodeModule      '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim StartLine As Long
    Dim ProcName As String
    Dim lastProcName As String
    Dim procs As New Collection
    Dim proc As vbeProcedure

    Dim i As Long

    ' Skip past any Option statement
    '   and any module-level variable declations.
    StartLine = codeMod.CountOfDeclarationLines + 1

    For i = StartLine To codeMod.CountOfLines
        ' get procedure name
        ProcName = codeMod.ProcOfLine(i, vbext_pk_Proc)
        If Not ProcName = lastProcName Then
            ' create new procedure object
            Set proc = New vbeProcedure
            proc.initialize ProcName, codeMod
            ' add it to collection
            procs.Add proc
            ' reset lastProcName
            lastProcName = ProcName
        End If
    Next i
    Set getProcedures = procs

End Function

Затем я обрабатываю каждую процедуру в данном модуле кода.

Private Sub fixProcNameConstants(codeMod As CodeModule)
    Dim procs As Collection
    Dim proc As vbeProcedure
    Dim i As Long 'line counter

    'getProcName codeMod
    Set procs = getProcedures(codeMod)

    For Each proc In procs
        With proc
            ' skip the proc.StartLine
            For i = .StartLine + 1 To .EndLine
                ' find constant PROC_NAME declaration
                If InStr(1, .ParentModule.Lines(i, 1), "Const PROC_NAME", vbTextCompare) Then
                    'Debug.Print .ParentModule.Lines(i, 1)
                    ' replace this whole line of code with the correct declaration
                    .ParentModule.ReplaceLine i, "Const PROC_NAME As String = " & Chr(34) & .Name & Chr(34)
                    'Debug.Print .ParentModule.Lines(i, 1)
                    Exit For
                End If
            Next i
        End With
    Next proc
End Sub

Наконец, назовем этот sub для каждого модуля кода в моем активном проекте (пока это не мой модуль "DevUtilities").

Public Sub FixAllProcNameConstants()
    Dim prj As vbProject
    Set prj = VBE.ActiveVBProject
    Dim codeMod As CodeModule
    Dim vbComp As VBComponent

    For Each vbComp In prj.VBComponents
        Set codeMod = vbComp.CodeModule
        ' don't mess with the module that'c calling this
        If Not codeMod.Name = "DevUtilities" Then
            fixProcNameConstants codeMod
        End If
    Next vbComp
End Sub

Я вернусь, если узнаю, какое колдовство vbWatchDog использует, чтобы открыть стек вызовов vba.

Ответ 4

Использовать Err.Raise

Для параметра Source pass in:

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

Ответ 5

Сообщение было неправильным, не вижу, как удалить мой пост, поэтому я заменил текст.

Ответ 6

Добавьте эту функцию в любой модуль, который вам нравится:

Function getModule_Func_Name()

Dim strModule, strFunction
   strModule = Application.VBE.ActiveCodePane.CodeModule
'   getProcedures (Application.VBE.ActiveCodePane.CodeModule)
strFunction = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
getModule_Func_Name = strModule & " , " & strFunction & "()"
End Function

И затем в вашей суб/функции используйте это как обработчик Err:

ErrHandler:
    ErrModule.ShowMessageBox getModule_Func_Name
    Resume ExitSub