logo标签列表

获取当前VBA函数的名称

ms-accessvba
40

为了处理错误代码，我想获取错误发生时当前的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
12个回答
17

虽然没有直接获取当前函数名称的方法，但是您可以利用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中也可以正常工作（除了使用类的一般麻烦之外）。

编辑：

为了回应David Fenton的评论，即这是一个相对复杂的解决方案，用于解决一个简单的问题，我认为问题实际上并不简单！

我想我们都同意，我们不希望给我们VBA程序中的每个单独的例程都提供自己的错误处理程序。（请参见我在此处的推理：VBA Error "Bubble Up"）

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

RAII方法允许我们使用VBA对象生命周期管理的自然行为来识别什么时候退出了一个例程，无论是通过“Exit”、“End”，还是错误。我的玩具示例只是用于说明这个概念。我自己的小型VBA框架中的真正的"tracer"肯定更复杂，但也做得更多：

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)

...

自动生成样板代码非常容易，尽管我实际上会手动输入，然后在测试过程中自动检查以确保例行程序/参数名称匹配。

2
对我来说，这似乎是一个相对简单问题的过于复杂的解决方案。 - David-W-Fenton
1
@David-W-Fenton，我不确定这是否真的那么简单。请查看我的编辑答案，了解我为什么建议采用这种方法。我很想听听您自己的方法。 - jtolle
1
@David-W-Fenton，没错，但当出现错误时，你应该怎么知道何时弹出？ RAII方法的整个目的是您不需要知道。 VBA 已经维护堆栈，并且已经知道如何在引发错误并最终在某个错误处理程序中处理它时解开它。 您只需实例化一个对象，然后忘记它； VBA会在您想要跟踪的东西-过程退出-发生时恰好销毁它。 在每个必须明确捕获日志并重新引发其捕获内容的例程中手动执行所有这些操作似乎很繁琐且容易出错。 - jtolle
因为VBA使用引用计数来进行内存清理，所以你绝对不能依赖它在对象超出范围时进行清理。 VBA维护一个堆栈，但它在编程上没有暴露出来（不知道为什么）。 - David-W-Fenton
1
我看不出在每个子程序中使用错误处理程序和在每个子程序中实例化一个类之间的区别。当然，我的建议并不是在每个子程序中都使用一个错误处理程序，而是采用一种不同的存储堆栈的方法，使用一个单一的存储结构（无论您如何实现），而不是多个类实例的复杂性。 - David-W-Fenton
显示剩余4条评论
7
我使用免费的MZTools for VBA中的错误处理程序按钮。 它会自动添加代码行以及子/函数名称。 现在，如果您重命名子/函数，则必须记得更改代码。
MZTools还内置了许多不错的功能。 例如，改进的查找屏幕以及最好的是一个按钮，显示调用此子/函数的所有位置。
快速浏览了一下MZTools，其中一两个功能对我很有用，谢谢Tony。 - maxhugen
2
嗯，我已经使用MZ Tools一年了...所以Tony，现在我正在使用超过1或2个功能！作为长期的Access程序员（有自己的一套好/坏实践），MZT已成为“必备”的附件:)谢谢！ - maxhugen
5

vbWatchdog 是一个商业解决方案，价格合理，功能强大。除了其他特点外，它还提供完全访问 VBA 调用堆栈的功能。我不知道有哪个产品可以做到这一点（我已经搜索过了）。

此外，它还有几个其他特点，包括变量检查和自定义错误对话框，但仅访问堆栈跟踪就已经物超所值了。

注意：我与该产品没有任何关联，只是一个极其满意的用户。

5

真的吗？为什么开发人员总是不断地解决同一个问题？使用Err.Raise发送过程名称到Err对象中...

对于Source参数，请传入：

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

我知道这不是最简短的代码，但如果你买不起商业产品来增强VBA IDE，或者像我们许多人一样，被限制在一个受限制的环境中工作，那么这就是最简单的解决方案。

3

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

Const METHOD_NAME = "GetCustomer"

 On Error Goto ErrHandler:
 ' Code

ErrHandler:
   MsgBox "Err in " & METHOD_NAME

你可以在MZ Tools for VBA中找到一些有用的东西。这是VB语言家族的开发者插件，由MVP编写。

1
是的，基本上就是我一直以来所做的事情，可以看看我的编辑过的帖子。谢谢。 - maxhugen
3

VBA没有内置的堆栈跟踪可以以编程方式访问。您需要设计自己的堆栈，并将其推入/弹出以实现类似的功能。否则，您需要在代码中硬编码函数/子程序名称。

是的，它确实有关系。但这与手头的问题无关。 - KevenDenen
4
Application.Caller与调用堆栈或了解哪个函数调用了当前函数无关。您的评论与此无关且没有帮助性。 - KevenDenen
2

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

to this in all Procedures on of MyForm. 

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
2
我已经从事编程工作18年了，这是我第一次在VBScript中看到Like运算符。我根本不知道它的存在。＃你总是可以教老狗新把戏 - Drew Chapin
2

这对我有用。 我在使用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的评论所述。 - maxhugen
这很有用，但可能会比较棘手，因为'Application.VBE.ActiveCodePane.TopLine'返回代码窗格顶部行的行号。所以，如果您处于调试模式，则procName可能会与实际过程交换。而且，您应该直接使用'Application.VBE.ActiveCodePane.CodeModule'而不是'Me.Name'。 - Lionel T.
0

代码很丑，但它能用。这个例子将为每个函数添加错误处理代码，同时包含一个字符串，其中包含函数名称。

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 函数，而且如果你在同一个模块上第二次运行它，会弄乱代码（在你添加了新函数后）。 - Vlado
0

Mark Ronollo的解决方案非常好用。

我需要提取所有模块中的所有过程名称以进行文档记录，因此我采用了他的代码并将其改编为以下函数，该函数检测我的所有代码中的所有过程名称，包括表单和模块，然后将其存储到我的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
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接