获取当前 VBA 函数的名称答案

【问题标题】：Get Name of Current VBA Function获取当前 VBA 函数的名称
【发布时间】：2011-04-17 01:38:11
【问题描述】：

对于错误处理代码，我想获取发生错误的当前 VBA 函数（或子函数）的名称。有谁知道如何做到这一点？

[编辑] 谢谢大家，我曾希望存在一个未记录的技巧来自行确定函数，但这显然不存在。我想我会继续使用我当前的代码：

Option Compare Database: Option Explicit: Const cMODULE$ = "basMisc"

Public Function gfMisc_SomeFunction$(target$)
On Error GoTo err_handler: Const cPROC$ = "gfMisc_SomeFunction"
    ...
exit_handler:
    ....
    Exit Function
err_handler:
    Call gfLog_Error(cMODULE, cPROC, err, err.Description)
    Resume exit_handler
End Function

【问题讨论】：

标签： ms-access vba

【解决方案1】：

不使用任何内置的 VBA 方式。您能做的最好的事情就是通过将方法名称硬编码为常量或常规方法级变量来重复自己。

Const METHOD_NAME = "GetCustomer"

 On Error Goto ErrHandler:
 ' Code

ErrHandler:
   MsgBox "Err in " & METHOD_NAME

您也许可以在MZ Tools for VBA 中找到方便的东西。它是 VB 系列语言的开发者插件。由 MVP 撰写。

【讨论】：

是的，几乎就是我一直在做的事情，请参阅我编辑的帖子。谢谢。

【解决方案2】：

VBA 没有任何您可以通过编程方式访问的内置堆栈跟踪。您必须设计自己的堆栈并将其推入/弹出以完成类似的事情。否则，您需要将函数/子名称硬编码到代码中。

【讨论】：

是的，确实如此。但这与手头的问题无关。
Application.Caller 与堆栈跟踪或知道哪个函数调用了当前函数无关。您的评论不相关且无益。

【解决方案3】：

没有什么可以获取当前函数名，但是您可以使用 VBA 对象生命周期是确定性的事实来构建一个相当轻量级的跟踪系统。例如，您可以使用以下代码创建一个名为“Tracer”的类：

Private proc_ As String

Public Sub init(proc As String)
    proc_ = proc
End Sub

Private Sub Class_Terminate()
    If Err.Number <> 0 Then
        Debug.Print "unhandled error in " & proc_
    End If
End Sub

然后在例程中使用该类，例如：

Public Sub sub1()
    Dim t As Tracer: Set t = New Tracer
    Call t.init("sub1")

    On Error GoTo EH

    Call sub2

    Exit Sub

EH:
    Debug.Print "handled error"
    Call Err.Clear
End Sub

Public Sub sub2()
    Dim t As Tracer: Set t = New Tracer
    Call t.init("sub2")

    Call Err.Raise(4242)
End Sub

如果你运行 'sub1'，你应该得到这个输出：

unhandled error in sub2
handled error

因为当错误导致例程退出时，您在“sub2”中的 Tracer 实例已被确定性破坏。

这种通用模式在 C++ 中经常出现，名称为“RAII”，但在 VBA 中也能正常工作（除了使用类的一般烦恼）。

编辑：

为了解决大卫芬顿的评论，这是一个简单问题的相对复杂的解决方案，我认为问题实际上没有那么简单！

我认为我们都同意我们不想为 VBA 程序中的每个例程都提供自己的错误处理程序，这是理所当然的。（在这里查看我的推理：VBA Error "Bubble Up"）

如果某些内部例程没有自己的错误处理程序，那么当我们确实捕获一个错误时，我们所知道的只是在触发错误处理程序的例程中或在调用堆栈中某个更深的地方的例程。因此，据我了解，问题实际上是跟踪我们程序的执行之一。跟踪例行输入当然很容易。但追踪出口确实可能相当复杂。例如，可能会引发错误！

RAII 方法允许我们使用 VBA 对象生命周期管理的自然行为来识别我们何时退出例程，无论是通过“退出”、“结束”还是错误。我的玩具示例只是为了说明这个概念。我自己的小 VBA 框架中真正的“跟踪器”当然更复杂，但也做得更多：

Private Sub Class_Terminate()
    If unhandledErr_() Then
        Call debugTraceException(callID_, "Err unhandled on exit: " & fmtCurrentErr())
    End If

    If sendEntryExit_ Then
        Select Case exitTraceStatus_
            Case EXIT_UNTRACED
                Call debugTraceExitImplicit(callID_)
            Case EXIT_NO_RETVAL
                Call debugTraceExitExplicit(callID_)
            Case EXIT_WITH_RETVAL
                Call debugTraceExitExplicit(callID_, retval_)
            Case Else
                Call debugBadAssumption(callID_, "unrecognized exit trace status")
        End Select
    End If
End Sub

但是使用它仍然非常简单，并且无论如何都比“每个例程中的 EH”方法更少样板：

Public Function apply(functID As String, seqOfArgs)
    Const PROC As String = "apply"
    Dim dbg As FW_Dbg: Set dbg = mkDbg(MODL_, PROC, functID, seqOfArgs)

...

自动生成样板文件很容易，尽管我实际输入它然后自动检查以确保例程/参数名称匹配作为我测试的一部分。

【讨论】：

在我看来对于一个相对简单的问题来说是一个非常复杂的解决方案。
@David-W-Fenton，我不确定它真的那么简单。请参阅我编辑的答案，了解我为什么建议这种方法。我很想听听你自己的方法。
我没有看到使用基于类的方法为每个子例程实例化类的实例的意义，而不是仅仅维护一个您推送/弹出的堆栈。后者可以用一个类来完成。
@David-W-Fenton，是的，但是您应该如何知道何时弹出，尤其是在引发错误时？ RAII 方法的全部意义在于您不需要。 VBA已经维护了一个堆栈，并且已经知道如何在出现错误并最终在某个错误处理程序中处理时展开它。您只需实例化一个对象，然后忘记它；当您要跟踪的事情（过程退出）发生时，VBA 会准确地破坏它。在每个例程中使用错误处理程序手动执行所有这些操作，这些程序必须记录并重新引发他们明确捕获的内容，这似乎令人筋疲力尽且容易出错。
我看不出在每个子程序中都有一个错误处理程序和在任何子程序中实例化一个类之间的区别。当然，我的建议是不是每个中的错误处理程序，而是存储堆栈的不同方法，具有单个存储结构（无论您如何实现它），而不是复杂性一个类的多个实例。

【解决方案4】：

我使用免费MZTools for VBA. 中的错误处理程序按钮，它会自动添加代码行以及子/函数名称。现在，如果您重命名子/函数，您必须记住更改代码。

MZTools 还内置了许多不错的功能。例如改进的查找屏幕，最棒的是一个按钮，向您显示调用此子/功能的所有位置。

【讨论】：

快速浏览了 MZTools，一两个功能对我很有用，谢谢 Tony。
嗯，我已经使用 MZ 工具一年了......所以，托尼，我现在使用的功能不止一两个！作为一名长期的 Access 程序员（有他自己的一套好/坏做法），MZT 已成为“必备”配件 :) 谢谢！

【解决方案5】：

vbWatchdog 是该问题的商业解决方案。它的功能价格非常合理。除其他功能外，它还提供对 VBA 调用堆栈的完全访问权限。我知道没有其他产品可以做到这一点（我已经看过了）。

还有其他一些功能，包括变量检查和自定义错误对话框，但仅访问堆栈跟踪就值得付出代价。

注意：除了我是一个非常满意的用户之外，我与该产品没有任何关系。

【讨论】：

【解决方案6】：

代码很丑，但它可以工作。此示例将向每个还包含带有函数名称的字符串的函数添加错误处理代码。

Function AddErrorCode()
    Set vbc = ThisWorkbook.VBProject.VBComponents("Module1")
    For VarVBCLine = 1 To vbc.codemodule.CountOfLines + 1000
        If UCase(vbc.codemodule.Lines(VarVBCLine, 1)) Like UCase("*Function *") And Not (UCase(vbc.codemodule.Lines(VarVBCLine, 1)) Like UCase("*Function FunctionReThrowError*")) Then
            If Not (vbc.codemodule.Lines(VarVBCLine + 1, 1) Like "*Dim VarFunctionName As String*") Then
                     vbc.codemodule.InsertLines VarVBCLine + 1, "Dim VarFunctionName as String"
                     vbc.codemodule.InsertLines VarVBCLine + 2, "VarFunctionName = """ & Trim(Mid(vbc.codemodule.Lines(VarVBCLine, 1), InStr(1, vbc.codemodule.Lines(VarVBCLine, 1), "Function") + Len("Function"), Len(vbc.codemodule.Lines(VarVBCLine, 1)))) & """"
                    VarVBCLine = VarVBCLine + 3
            End If
        End If
         If UCase(vbc.codemodule.Lines(VarVBCLine, 1)) Like UCase("*End Function*") Then
            If Not (vbc.codemodule.Lines(VarVBCLine - 1, 1) Like "*Call FunctionReThrowError(Err, VarFunctionName)*") And Not (UCase(vbc.codemodule.Lines(VarVBCLine - 1, 1)) Like UCase("*Err.Raise*")) Then
                vbc.codemodule.InsertLines VarVBCLine, "ErrHandler:"
                vbc.codemodule.InsertLines VarVBCLine + 1, "Call FunctionReThrowError(Err, VarFunctionName)"
                VarVBCLine = VarVBCLine + 2
            End If
        End If
    Next VarVBCLine
   If Not (vbc.codemodule.Lines(1, 1) Like "*Function FunctionReThrowError(ByVal objError As ErrObject, PasFunctionName)*") Then
        vbc.codemodule.InsertLines 1, "Function FunctionReThrowError(ByVal objError As ErrObject, PasFunctionName)"
        vbc.codemodule.InsertLines 2, "Debug.Print PasFunctionName & objError.Description"
        vbc.codemodule.InsertLines 3, "Err.Raise objError.Number, objError.Source, objError.Description, objError.HelpFile, objError.HelpContext"
        vbc.codemodule.InsertLines 4, "End Function"
    End If
End Function

【讨论】：

这段代码有两个问题：它在 Option 声明之前插入了 FunctionReThrowError 函数，如果你在同一个模块上第二次运行它，它会弄乱代码（在你添加新函数之后）跨度>

【解决方案7】：

这对我有用。我在 2010 年。

ErrorHandler:
    Dim procName As String
    procName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
    MyErrorHandler err, Me.Name, getUserID(), procName
    Resume Exithere

【讨论】：

我最终使用了 MZ-Tools 插件（我强烈推荐），它可以根据 Tony Toews cmets 在任何函数/子中自动插入我的原始错误处理代码。跨度>
它很有用，但可能很棘手，因为 'Application.VBE.ActiveCodePane.TopLine' 返回代码窗格顶部的行号。因此，如果您处于调试模式，则可以使用实际过程切换 procName。而不是“Me.Name”，您应该直接使用“Application.VBE.ActiveCodePane.CodeModule”。

【解决方案8】：

真的吗？为什么开发人员会一遍又一遍地解决同样的问题？使用 Err.Raise 将获取过程名称发送到 Err 对象中...

对于Source参数传入：

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

我知道这不是最短的一个班轮，但如果您买不起用于增强 VBA IDE 的商业产品，或者像我们中的许多人一样，只能在锁定的环境中工作，那么这是最简单的解决方案。

【讨论】：

【解决方案9】：

sean hendrix 的代码一点也不差。我稍微改进了一下：

Public Function AddErrorCode(modName As String)
    Dim VBComp As Object
    Dim VarVBCLine As Long

    Set VBComp = Application.VBE.ActiveVBProject.VBComponents(modName)

    For VarVBCLine = 1 To VBComp.CodeModule.CountOfLines + 1000
        If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*Function *") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine + 1, 1) Like "On Error GoTo *") Then
                     VBComp.CodeModule.InsertLines VarVBCLine + 1, "On Error GoTo ErrHandler_"
                     VBComp.CodeModule.InsertLines VarVBCLine + 2, "    Dim VarThisName as String"
                     VBComp.CodeModule.InsertLines VarVBCLine + 3, "    VarThisName = """ & Trim(Mid(VBComp.CodeModule.Lines(VarVBCLine, 1), InStr(1, VBComp.CodeModule.Lines(VarVBCLine, 1), "Function") + Len("Function"), Len(VBComp.CodeModule.Lines(VarVBCLine, 1)))) & """"
                    VarVBCLine = VarVBCLine + 4
            End If
        End If
         If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*End Function*") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine - 1, 1) Like "*Resume '*") And Not (UCase(VBComp.CodeModule.Lines(VarVBCLine - 1, 1)) Like UCase("*Err.Raise*")) Then
                VBComp.CodeModule.InsertLines VarVBCLine, "ExitProc_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 1, "    Exit Function"
                VBComp.CodeModule.InsertLines VarVBCLine + 2, "ErrHandler_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 3, "    Call LogError(Err, Me.Name, VarThisName)"
                VBComp.CodeModule.InsertLines VarVBCLine + 4, "    Resume ExitProc_"
                VBComp.CodeModule.InsertLines VarVBCLine + 5, "    Resume ' use for debugging"
                VarVBCLine = VarVBCLine + 6
            End If
        End If

        If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*Private Sub *") Or UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*Public Sub *") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine + 1, 1) Like "On Error GoTo *") Then
                     VBComp.CodeModule.InsertLines VarVBCLine + 1, "On Error GoTo ErrHandler_"
                     VBComp.CodeModule.InsertLines VarVBCLine + 2, "    Dim VarThisName as String"
                     VBComp.CodeModule.InsertLines VarVBCLine + 3, "    VarThisName = """ & Trim(Mid(VBComp.CodeModule.Lines(VarVBCLine, 1), InStr(1, VBComp.CodeModule.Lines(VarVBCLine, 1), "Sub") + Len("Sub"), Len(VBComp.CodeModule.Lines(VarVBCLine, 1)))) & """"
                    VarVBCLine = VarVBCLine + 4
            End If
        End If
         If UCase(VBComp.CodeModule.Lines(VarVBCLine, 1)) Like UCase("*End Sub*") Then
            If Not (VBComp.CodeModule.Lines(VarVBCLine - 1, 1) Like "*Resume '*") And Not (UCase(VBComp.CodeModule.Lines(VarVBCLine - 1, 1)) Like UCase("*Err.Raise*")) Then
                VBComp.CodeModule.InsertLines VarVBCLine, "ExitProc_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 1, "    Exit Sub"
                VBComp.CodeModule.InsertLines VarVBCLine + 2, "ErrHandler_:"
                VBComp.CodeModule.InsertLines VarVBCLine + 3, "    Call LogError(Err, Me.Name, VarThisName)"
                VBComp.CodeModule.InsertLines VarVBCLine + 4, "    Resume ExitProc_"
                VBComp.CodeModule.InsertLines VarVBCLine + 5, "    Resume ' use for debugging"
                'VBComp.CodeModule.DeleteLines VarVBCLine + 5, 1
                'VBComp.CodeModule.ReplaceLine VarVBCLine + 5, "    Resume ' replaced"
                VarVBCLine = VarVBCLine + 6
            End If
        End If

    Next VarVBCLine

End Function

你可以把它放在一个单独的模块中，这样调用它：

AddErrorCode "Form_MyForm"

在即时窗口中。它会改变你的表单代码：

Private Sub Command1_Click()

    Call DoIt

End Sub

在MyForm 的所有Procedure 中对此进行了说明。

Private Sub Command1_Click()
On Error GoTo ErrHandler_
   Dim VarThisNameAs String
   VarThisName = "Command1_Click()"

        Call DoIt

ExitProc_:
    Exit Sub
ErrHandler_:
    Call LogError(Err, Me.Name, VarThisName)
    Resume ExitProc_
    Resume ' use for debugging
End Sub

您可以为同一个表单重复运行它，它不会重复代码。您需要创建一个公共子程序来捕获错误并将代码写入文件或数据库以记录它。

Public Sub LogError(ByVal objError As ErrObject, PasModuleName As String, Optional PasFunctionName As String = "")
    On Error GoTo ErrHandler_
    Dim sql As String
    ' insert the values into a file or DB here
    MsgBox "Error " & Err.Number & Switch(PasFunctionName <> "", " in " & PasFunctionName) & vbCrLf & " (" & Err.Description & ") ", vbCritical, Application.VBE.ActiveVBProject.Name
Exit_:
    Exit Sub
ErrHandler_:
    MsgBox "Error in LogError function " & Err.Number
    Resume Exit_
    Resume ' use for debugging
End Sub

编辑：这是改进的代码：

Public Sub InsertErrHandling(modName As String)
    Dim Component As Object
    Dim Name As String
    Dim Kind As Long
    Dim FirstLine As Long
    Dim ProcLinesCount As Long
    Dim Declaration As String
    Dim ProcedureType As String
    Dim Index As Long, i As Long, j As Long
    Dim LastLine As Long
    Dim StartLines As Collection, LastLines As Collection, ProcNames As Collection, ProcedureTypes As Collection
    Dim gotoErr As Boolean

    Kind = 0
    Set StartLines = New Collection
    Set LastLines = New Collection
    Set ProcNames = New Collection
    Set ProcedureTypes = New Collection

    Set Component = Application.VBE.ActiveVBProject.VBComponents(modName)
        With Component.CodeModule

            ' Remove empty lines on the end of the code
            For i = .CountOfLines To 1 Step -1
                If Component.CodeModule.Lines(i, 1) = "" Then
                  Component.CodeModule.DeleteLines i, 1
                Else
                    Exit For
                End If
            Next i

            Index = .CountOfDeclarationLines + 1
            Do While Index < .CountOfLines
                gotoErr = False
                Name = .ProcOfLine(Index, Kind)
                FirstLine = .ProcBodyLine(Name, Kind)
                ProcLinesCount = .ProcCountLines(Name, Kind)
                Declaration = Trim(.Lines(FirstLine, 1))
                LastLine = FirstLine + ProcLinesCount - 2
                If InStr(1, Declaration, "Function ", vbBinaryCompare) > 0 Then
                    ProcedureType = "Function"
                Else
                    ProcedureType = "Sub"
                End If
               Debug.Print Component.Name & "." & Name, "First: " & FirstLine, "Lines:" & ProcLinesCount, "Last: " & LastLine, Declaration

                ' do not insert error handling if there is one already:
                For i = FirstLine To LastLine Step 1
                    If Component.CodeModule.Lines(i, 1) Like "*On Error*" Then
                        gotoErr = True
                        Exit For
                    End If
                Next i
                If Not gotoErr Then

                    StartLines.add FirstLine
                    LastLines.add LastLine
                    ProcNames.add Name
                    ProcedureTypes.add ProcedureType
                Else
                    Debug.Print Component.Name & "." & Name, "Existing Error handling"
                End If

                Index = FirstLine + ProcLinesCount + 1
            Loop

            For i = LastLines.Count To 1 Step -1
                If Not (Component.CodeModule.Lines(StartLines.Item(i) + 1, 1) Like "*On Error GoTo *") Then
                    If (Component.CodeModule.Lines(LastLines.Item(i) - 1, 1)) Like "*End " & ProcedureTypes.Item(i) Then
                        j = LastLines.Item(i) - 1
                    Else
                        j = LastLines.Item(i)
                    End If
                    Component.CodeModule.InsertLines j, "ExitProc_:"
                    Component.CodeModule.InsertLines j + 1, "    DoCmd.Hourglass False"
                    Component.CodeModule.InsertLines j + 2, "    Exit " & ProcedureTypes.Item(i)
                    Component.CodeModule.InsertLines j + 3, "ErrHandler_:"
                    Component.CodeModule.InsertLines j + 4, "    DoCmd.Hourglass False"
                    Component.CodeModule.InsertLines j + 5, "    Call LogError(Err.Number, Err.Description,  """ & modName & """, """ & ProcNames.Item(i) & """)"
                    Component.CodeModule.InsertLines j + 6, "    Resume ExitProc_"
                    Component.CodeModule.InsertLines j + 7, "    Resume ' use for debugging"

                    Component.CodeModule.InsertLines StartLines.Item(i) + 1, "    On Error GoTo ErrHandler_"
                    Debug.Print Component.Name & "." & ProcNames.Item(i), "First: " & StartLines.Item(i), "Last: " & j, "   Inserted"
                End If
            Next i
        End With
End Sub

【讨论】：

我已经编程了 18 年，这是我第一次在 VBScript 中看到 Like 运算符。我根本不知道这甚至存在。 #YouCanAlwaysTeachAnOldDogNewTricks

【解决方案10】：

Mark Ronollo 的解决方案非常有效。

出于文档目的，我需要从 all 模块中提取 all 过程名称，因此我将他的代码修改为下面的函数，该函数检测所有过程我所有代码中的名称，包括表单和模块，然后将其存储到我的 Access 文件中名为 VBAProcedures 的表中（该表只有一个唯一键，一个名为 [Module] 的列和一个名为 [Procedure] 的列。它为我节省了数小时的体力劳动！

    Sub GetAllVBAProcedures()
    Dim Message As String, Query As String, tmpModule As String
    Dim MaxLines As Integer, tmpLine As Integer, i As Integer
    MaxLines = 4208
    Dim obj As AccessObject, db As Object
    Query = "delete from VBAProcedures"
    CurrentDb.Execute Query
    For i = 1 To Application.VBE.CodePanes.Count
        tmpModule = ""
        For tmpLine = 1 To MaxLines
            Message = Application.VBE.CodePanes(i).CodeModule.ProcOfLine(tmpLine, 0)
            If Message <> tmpModule And Message <> "" Then
                tmpModule = Message
                Query = "insert into VBAProcedures ([Module], [Procedure]) values ('" & Application.VBE.CodePanes(i).CodeModule.Name & "', '" & tmpModule & "')"
                CurrentDb.Execute Query
            End If
        Next tmpLine
    Next i
    End Sub

【讨论】：

【解决方案11】：

我们创建了一个名为 "Error Debug Log" 的表来保存错误信息，创建一个默认字段为 Now() 的日期字段（以自动填充它发生的日期）和另一个文本字段来保存函数的名称.

创建失败时添加记录的公共函数：

Public Function DebugFunc(FuncName As String)
    FuncName = "INSERT INTO [Error Debug Log] ( FunctionName ) SELECT """ & (FuncName) & """"
    DoCmd.RunSQL ((FuncName))
End Function

然后Call它发生错误时，我们发现这更容易，因此信息在我们可以稍后检查的表中。

Call DebugFunc("name of your function or any other data")

如果您打算花时间为具有函数名称的变量分配值，那么在需要时编写名称会更容易。

【讨论】：