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

Question

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

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

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 可扩展性库完成了一些元编程，但在运行时没有取得任何成功。我以前没有尝试过，在我再次尝试之前，我想知道这是否有可能。

行不通的事情

vbWatchDog。这确实有效，但我无法在该项目中使用第三方工具。

注意

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

Answer 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

那么下面的代码

应该

可以工作。

注意：我无法彻底测试它，但我相信您可以调整它并使其工作（如果有任何帮助的话）。

注意：通过 VBE 中的工具 -> 引用添加对

Visual Basic for Applications Extensibility 5.3

的引用

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

Answer 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 可扩展性自动添加样板错误处理代码（如上所述）感兴趣。我从来没有抽出时间实际去做，但我相信这是很有可能的。

Answer 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

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

Answer 4

对于Source参数传入：

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

Answer 5

出现错误时，我显示此字符串。因为我对所有新过程都使用模板，所以我很少忘记编辑错误字符串的输入

这样做的好处是我看到大约有 6 个例程（从上到下，最新到最早）被执行。

在模板代码中，如下所示，我编辑“private sub”以满足我的需要并调整例程名称。然后我在更新错误字符串的行中输入模块名称和例程名称。

Public errS As String Private Sub Template() 'macro description errS = VBA.left(vbLf & "-> " & "mod99_Template.Template" & VBA.Replace(errS, "->", " "), IIf(VBA.InStr(140, errS, vbLf, vbTextCompare) = 0, 280, VBA.InStr(140, errS, vbLf, vbTextCompare))) ' Application.Run "'" & ThisWorkbook.Name & "'!mod99_Template.Template" 'Dim StartTime As Double: StartTime = Timer 'Timer Application.ScreenUpdating = False '############################ PARAMETRI ########################################## '############################ PROGRAM ########################################## On Error GoTo ExitProc Dim wbA As Workbook: Set wbA = ActiveWorkbook Dim wsA As Worksheet: Set wsA = Sheet1 'Sheet1 / wbA.Sheets(shtPregled) / wbA.ActiveSheet With wsA End With ExitProc: If Err.Number <> 0 Then MsgBox "Error occured in: " & errS & vbLf & vbLf & Err.Description: Err.Clear: Stop Set wsA = Nothing Set wbA = Nothing Application.ScreenUpdating = True 'MsgBox "This code ran successfully in " & Round(Timer - StartTime, 2) & " seconds", vbInformation 'Timer End Sub

这当然不是最好的解决方案，但它很简单，并且在受 VBE 保护的工作簿上运行时效果很好。

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

问题描述投票：0回答：5

5个回答

最新问题

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

问题描述 投票：0回答：5

5个回答

最新问题

问题描述投票：0回答：5