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

时间：2014-05-30 00:42:41

标签： vba error-handling

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

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

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库进行了一些元编程，但是我在运行时没有取得任何成功。我没有以前的尝试，在我再次尝试这个尝试之前，我想知道它是否可以远程实现。

不起作用的事情

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

    4. 注意

    vbWatchdog似乎是通过API调用直接访问内核内存来实现的。

4 个答案:

答案 0 :(得分：5)

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

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

例如

如果你能避免在不同的子/函数中重复错误处理程序标签

不要⇩⇩⇩⇩⇩ 

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的引用 - ＆gt; 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

答案 1 :(得分：4)

我使用基于链接节点的堆栈类包装在单例中，全局实例化（通过属性完成）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 Extensibility自动添加样板错误处理代码（如上所述）感兴趣。我从来没有真正去做过，但我相信这很有可能。

答案 2 :(得分：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

最后为我的活动项目中的每个代码模块调用该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调用堆栈，我会回来的。

答案 3 :(得分：1)

使用Err.Raise

对于Source参数传入：

f.keys()
相关问题
最新问题