vba 如何在运行时获取过程或函数名称？

How to get the procedure or function name at runtime?

提问by RubberDuck

Is there anyway to return the name of a function or procedure at runtime?

有没有办法在运行时返回函数或过程的名称？

I'm currently error handling something like this:

我目前正在错误处理这样的事情：

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

I recently experienced one of my constants lying to me after I updated a function name, but not the constant value. I want to return the name of the procedure to my error handler.

我最近在更新函数名称后遇到了一个常量对我撒谎，但不是常量值。我想将过程的名称返回给我的错误处理程序。

I know that I will have to interact with the VBIDE.CodeModuleobject to find it. I've done a little bit of meta-programming with the Microsoft Visual Basic for Applications Extensibility library, but I've not had any success with doing this at runtime. I don't have my previous attempts, and before I dig my heels in to try this again, I want to know if it's even remotely possible.

我知道我必须与VBIDE.CodeModule对象交互才能找到它。我已经使用 Microsoft Visual Basic for Applications Extensibility 库进行了一些元编程，但在运行时执行此操作并没有取得任何成功。我之前没有尝试过，在我全力以赴再次尝试之前，我想知道这是否有可能实现。

Things that won't work

行不通的事情

1. Using some built in VBA Library to access the call stack. It doesn't exist.
2. Implementing my own call stack by pushing and popping procedure names from an array as I enter and exit each one. This still requires that I pass the proc name somewhere else as a string.
3. A third party tool like vbWatchDog. This doeswork, but I can't use a third party tool for this project.

1. 使用一些内置的 VBA 库来访问调用堆栈。它不存在。
2. 通过在我进入和退出每个数组时从数组中推送和弹出过程名称来实现我自己的调用堆栈。这仍然需要我将 proc 名称作为字符串传递到其他地方。
3. 第三方工具，如vbWatchDog。这确实有效，但我不能为这个项目使用第三方工具。

Note

笔记

vbWatchdog seems to do this by directly accessing the kernel memory via API calls.

vbWatchdog 似乎是通过 API 调用直接访问内核内存来做到这一点的。

采纳答案by RubberDuck

I am not quite sure how helpful this is going to be...

我不太确定这会有多大帮助......

The good thing is that you will not have to worry about the sub/function name - you are free to change it. All you have to care about is the uniqueness of the error handler label name.

好处是您不必担心子/函数名称 - 您可以自由更改它。您只需要关心错误处理程序标签名称的唯一性。

For example

例如

if you can avoid duplicate error handler labelsin different subs/functions

如果您可以避免在不同的 subs/functions 中出现重复的错误处理程序标签

don't do ?????

不做？？？？

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

then the below code shouldwork.

那么下面的代码应该可以工作。

Note: I haven't been able to test it thoroughly but I am sure you can tweak it and get it work if it's of any help.

注意：我无法对其进行彻底测试，但我相信如果有帮助，您可以对其进行调整并使其正常工作。

Note: Add references to Visual Basic for Applications Extensibility 5.3via Tools -> References in VBE

注意：Visual Basic for Applications Extensibility 5.3在 VBE 中添加对via Tools -> References 的引用

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's a function
            GetFnOrSubName = Split(Mid$(code, isFunction, 40), "(")(0)
        Else
            ' it's a sub
            GetFnOrSubName = Split(Mid$(code, isSub, 40), "(")(0)
        End If

    End If

End Function

回答by Blackhawk

I use a linked node based stack class wrapped in a singleton, globally instanced (done through Attributes) CallStackclass. It allows me to perform error handling like David Zemens suggests (saving the procedure name each time):

我使用一个基于链接节点的堆栈类，该类封装在一个单例、全局实例化（通过属性完成）CallStack类中。它允许我像 David Zemens 建议的那样执行错误处理（每次保存过程名称）：

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

If it would be helpful to the discussion, I can post the associated code. The CallStack class has a Peekmethod to find out what the most recently called function is and a StackTracefunction to get a string output of the entire stack.

如果对讨论有帮助，我可以发布相关代码。CallStack 类有一个Peek方法可以找出最近调用的函数是什么，还有一个StackTrace函数可以获取整个堆栈的字符串输出。

---

---

More specifically to your question, I've always been interested in using VBA Extensibility to add the boiler-plate error handling code (as above) automatically. I've never gotten around to actually doing it, but I believe it's quite possible.

更具体地说，我一直对使用 VBA 扩展性自动添加样板错误处理代码（如上）感兴趣。我从来没有真正做到过，但我相信这是很有可能的。

回答by RubberDuck

The following does not exactly answer my question, but it does solve my problem. It will need to be run during development prior to publishing the application.

以下内容不能完全回答我的问题，但确实解决了我的问题。在发布应用程序之前，它需要在开发期间运行。

My workaround relies on the fact that all of my constants are named the same because I am using CPearson's codeto insert the constants into my procedures during development.

我的解决方法依赖于这样一个事实，即我的所有常量都命名为相同，因为我在开发过程中使用CPearson 的代码将常量插入到我的过程中。

The VBIDE library doesn't support procedures well, so I wrapped them up in a class module named vbeProcedure.

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

Then I added a function to my DevUtilitiesmodule (that's important later) to create a vbeProcedureobject and return a collection of them.

然后我在我的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

Next I loop through each procedure in a given code module.

接下来我循环遍历给定代码模块中的每个过程。

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

Finally calling that sub for each code module in my active project (so long as it isn't my "DevUtilities" module).

最后为我活动项目中的每个代码模块调用该子模块（只要它不是我的“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

I'll come back if I ever figure out what kind of sorcery vbWatchDog is using to expose the vba call stack.

如果我弄清楚 vbWatchDog 使用什么样的魔法来公开 vba 调用堆栈，我会回来的。

回答by Mark Ronollo

Use Err.Raise

使用 Err.Raise

For the Source parameter pass in:

对于传入的 Source 参数：

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