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

Posted 2023-02-24

【中文标题】如何在运行时获取过程或函数名称？

【英文标题】：How to get the procedure or function name at runtime?

【发布时间】：2014-07-19 15:59:05

【问题描述】：

是否有任何方法可以在运行时返回函数或过程的名称？

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

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 for Applications Extensibility 库进行了一些元编程，但在运行时我没有成功。我以前没有尝试过，在我再次尝试这个之前，我想知道它是否有可能。

行不通的事情

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

注意

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

【问题讨论】：

几个月前我查看了这个结果，结果要么不可能，要么我的 Google-fu 找不到。 OnError GoTo... 在调用过程中引发错误（不是发生错误 的过程，并且调用堆栈不会通过 VBA 向您公开，我能做的最好的事情是使用全局字符串变量和在每个过程的开头分配“活动”过程名称。并不完美，因为一个子可能会在返回“主”子中的错误之前调用多个过程（无需重新分配字符串），但足够接近我的需要。

这是个好主意@DavidZemens。我可能会尝试这似乎比弄乱可扩展性库要简单得多。吨的开销也少。谢谢。

另见：cpearson.com/excel/InsertProcedureNames.aspx 确认 “在 VBA 中，无法以编程方式确定当前正在运行的过程的名称。也就是说，无法获取过程它自己的名字。这样的功能在生成调试和诊断报告时会非常有用"...然后继续描述类似于我上面提到的内容。最终我不认为 ti 很有用，除非每个过程都有自己的错误处理，因为我上面引用的限制:)

我们现在越来越闲聊了，但我最近 -hacked- err... 改进了 Steve McMahon 的注册表类，使其可以在 vba 中工作。为它添加了几个例程。 My version on google drive。我在上面写了一个DSN Class。

@ckuhn203 我无法让Erl 方法工作。即使我对999 On Error GoTo <label> 之类的行进行编号，Erl 函数也会返回999，但CodeMod.Find() 不会使用值999 进行计算，因为它实际上是查看行999 而不是别名@ 987654335@ :(

【参考方案1】：

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

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

例如

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

不要做⇩⇩⇩⇩⇩

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'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

【讨论】：

努力。它不会说谎，但要维持这将是一场噩梦。

@ckuhn203 不知道为什么这会是一场噩梦？只需获取唯一标签并将其作为参数传递。

我会接受你的回答，因为它最接近我的要求。

Application.VBE.ActiveCodePane.CodeModule.Name 返回当前在 VBA 编辑器中打开的模块的名称，而不是当前正在执行的模块。

Application.VBE.ActiveCodePane 可能未激活 并导致应用程序行为异常（例如，Err 对象不可用的错误：-( ) 有时。激活使用VBE.ActiveVBProject.VBComponents("Module1").Activate。详情请看这里：***.com/a/32749416/1915920

【参考方案2】：

我使用了一个基于链接节点的堆栈类，它封装在一个单例中，全局实例化（通过属性完成）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

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

---

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

【讨论】：

再一次，我们手动维护一个字符串，如果输入不当或维护失败，该字符串可能会撒谎。我得出的结论是“vba”无法做到这一点。 vbWatchDog 似乎通过直接访问内核内存来完成它，但我只是不明白它是如何工作的。我正在开发一个实用程序，如果它与实际过程名称不匹配，它将更正我的 proc_name 常量。

绝对有可能。我使用可扩展性库将我的样板错误处理放入我的模块中。

@ckuhn203 Interesting reading. 我可以想象COM自省可能允许找到类和成员的名称，但可能不是活动的VBA函数:(

读起来很有趣。我需要找点时间消化一下。

【参考方案3】：

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

我的解决方法依赖于我的所有常量都被命名为相同的事实，因为我在开发过程中使用CPearson's code 将常量插入到我的过程中。

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

最后为我的活动项目中的每个代码模块调用该子程序（只要它不是我的“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 调用堆栈，我会回来的。

【讨论】：

vbWatchdog 将预编译代码注入内存并用作类对象。由于作者知道如何反编译已编译的 VBA，因此他从已编译的代码中获取了 proc_name 和其他信息。我也猜想，因为他知道如何反编译，所以他实际上修改了错误部分，因此只要有任何错误到达系统级别，就可以调用他的程序。就我个人而言，我很想看看你的过程。

@krishKM 我最终想通了，但无法复制 vbWatchdog 的功能。所以，除了对这里的课程进行一些改进之外，这正是我所做的。这有点难看。大量的样板，需要考虑一下应该从哪里报告错误。如果你对我在这里提到的类的当前状态感兴趣，更新版本在我的VBEX repo on Github，但不幸的是我用来修复我的项目的代码不是。

【参考方案4】：

使用 Err.Raise

对于Source参数传入：

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

【讨论】：

Me.Name 不起作用，甚至在类模块中也不起作用。其余的将返回方法名称。如果ActiveCodePane 未初始化，请参阅***.com/questions/23945321/…