获取当前 VBA 函数的名称
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/3792134/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Get Name of Current VBA Function
提问by maxhugen
For error handling code, I would like to get the name of the current VBA function (or sub) that the error occurred in. Does anyone know how this could be done?
对于错误处理代码，我想获取发生错误的当前 VBA 函数（或子函数）的名称。有谁知道如何做到这一点？
[EDIT] Thanks all, I had hoped that an undocumented trick existed to self-determine the function, but that obviously doesn't exist. Guess I'll stay with my current code:
[编辑] 谢谢大家，我曾希望存在一个未记录的技巧来自我确定函数，但这显然不存在。猜猜我会保留我当前的代码：
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
回答by jtolle
There's nothing to get the current function name, but you can build a fairly lightweight tracing system using the fact that VBA object lifetimes are deterministic. For example, you can have a class called 'Tracer' with this code:
没有什么可以获取当前函数名称，但是您可以使用 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
and then use that class in routines like:
然后在例程中使用该类，例如：
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
If you run 'sub1', you should get this output:
如果你运行“sub1”，你应该得到这个输出：
unhandled error in sub2
handled error
because your Tracer instance in 'sub2' was deterministically destroyed when the error caused an exit from the routine.
因为当错误导致例程退出时，“sub2”中的 Tracer 实例被确定性地破坏了。
This general pattern is seen a lot in C++, under the name "RAII", but it works just fine in VBA too (other than the general annoyance of using classes).
这种通用模式在 C++ 中经常出现，名称为“RAII”，但它在 VBA 中也能正常工作（除了使用类的普遍烦恼）。
EDIT:
编辑：
To address David Fenton's comment that this is a relatively complicated solution to a simple problem, I don't think the problem is actually that simple!
为了解决 David Fenton 的评论，即这是对简单问题的相对复杂的解决方案，我认为问题实际上没有那么简单！
I'm taking it for granted that we all agree that we don't want to give every single routine in our VBA program its own error handler. (See my reasoning here: VBA Error "Bubble Up")
我想当然地认为我们都同意我们不想给 VBA 程序中的每个例程都有自己的错误处理程序。（请参阅我的推理：VBA 错误“冒泡”）
If some internal routines don't have their own error handlers, then when we docatch an error, all we know is that is happened in the routine with the error handler that fired or in a routine somewhere deeper in the call stack. So the problem as I understand it is really one of tracing the executionof our program. Tracing routine entry is easy of course. But tracing exit can indeed be quite complicated. For example, there might be an error that gets raised!
如果某些内部例程没有自己的错误处理程序，那么当我们确实捕获错误时，我们所知道的就是发生在触发错误处理程序的例程中或调用堆栈中某个位置的例程中。所以我理解的问题实际上是跟踪我们程序的执行之一。跟踪常规条目当然很容易。但是跟踪出口确实可能相当复杂。例如，可能会引发一个错误！
The RAII approach allows us to use the natural behavior of VBA object life management to recognize when we've exited a routine, whether through an 'Exit', 'End', or error. My toy example is just meant to illustrate the concept. The real "tracer" in my own little VBA framework is certainly more complex, but also does more:
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
But using it is still pretty simple, and amounts to less boilerplate than the "EH in every routine" approach anyway:
但是使用它仍然非常简单，并且无论如何都比“EH in everyroutine”方法更少样板：
Public Function apply(functID As String, seqOfArgs)
Const PROC As String = "apply"
Dim dbg As FW_Dbg: Set dbg = mkDbg(MODL_, PROC, functID, seqOfArgs)
...
Automatically generating the boilerplate is easy, although I actually type it in and then automatically check to make sure routine/arg names match as part of my tests.
自动生成样板很容易，尽管我实际上是输入它然后自动检查以确保例程/参数名称匹配作为我测试的一部分。
回答by Tony Toews
I use the error handler button within the free MZTools for VBA.It automatically adds the lines of code along with the sub/function name. Now if you rename the sub/function you have to remember to change the code.
我使用免费的MZTools for VBA 中的错误处理程序按钮。它会自动添加代码行以及子/函数名称。现在，如果您重命名子/函数，则必须记住更改代码。
MZTools has many nice functions built in as well. Such as an improved find screen and the best of all is a button showing you all the places where this sub/function is called.
MZTools 还内置了许多不错的功能。例如改进的查找屏幕，最棒的是一个按钮，显示调用此子/功能的所有位置。
回答by mwolfe02
vbWatchdogis a commercial solution to the problem. It is very reasonably priced for its capabilities. Among other features it offers full access to the VBA call stack. I know of no other product that does this (and I've looked).
vbWatchdog是该问题的商业解决方案。它的功能价格非常合理。除了其他功能外，它还提供对 VBA 调用堆栈的完全访问。我知道没有其他产品可以做到这一点（我已经看过了）。
There are several other features including variable inspection and custom error dialog boxes, but the access to the stack trace alone is worth the price of admission.
还有其他一些功能，包括变量检查和自定义错误对话框，但仅访问堆栈跟踪就值得付出代价。
NOTE: I am in no way affiliated with the product except that I am an extremely satisfied user.
注意：除了我是一个非常满意的用户之外，我与该产品没有任何关联。
回答by p.campbell
Not using any built-in VBA way. The best you'll be able to do is repeat yourself by hardcoding the method name as a constant or regular method-level variable.
不使用任何内置的 VBA 方式。您能做的最好的事情就是通过将方法名称硬编码为常量或常规方法级变量来重复自己。
Const METHOD_NAME = "GetCustomer"
On Error Goto ErrHandler:
' Code
ErrHandler:
MsgBox "Err in " & METHOD_NAME
You may be able to find something handy in the MZ Tools for VBA. It's a developer add-in for the VB family of languages. Written by an MVP.
您可以在MZ Tools for VBA 中找到一些方便的东西。它是 VB 语言系列的开发人员插件。由 MVP 撰写。
回答by KevenDenen
VBA doesn't have any built-in stack trace that you can access programatically. You'd have to design your own stack and push/pop onto that to accomplish something similar. Otherwise, you'll need to hard code your function/sub names into the code.
VBA 没有任何可以以编程方式访问的内置堆栈跟踪。您必须设计自己的堆栈并将其推入/弹出以完成类似的事情。否则，您需要将您的函数/子名称硬编码到代码中。
回答by Randall Porter
This works for me. I am on 2010.
这对我有用。我在 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
回答by Vlado
The code of sean hendrix is not bad at all. I improved it a little bit:
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
You can put it in a separate module and call it like this:
你可以把它放在一个单独的模块中并像这样调用它：
AddErrorCode "Form_MyForm"
in Immediate window. It will change your form code from this:
在立即窗口中。它将从此更改您的表单代码：
Private Sub Command1_Click()
Call DoIt
End Sub
to this in all Procedures on of MyForm.
在 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
You can run it repeatedly for the same form and it will not duplicate the code. You need to create a public sub to catch the errors and write the code to a file or DB to log it.
您可以为同一个表单重复运行它，它不会重复代码。您需要创建一个公共子来捕获错误并将代码写入文件或数据库以记录它。
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
Edit: Here is improved code:
编辑：这是改进的代码：
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
回答by Israel Romero
Mark Ronollo's solution works like a charm.
Mark Ronollo 的解决方案很有魅力。
I had the need to extract allprocedure names from allmodules for documentation purposes, so I took his code and adapted it into the function below, which detects all procedure names in all my code, including forms and modules, and then stores it into a table on my Access file called VBAProcedures(the table simply has a unique key, a column named [Module]and a column named [Procedure]. It saved me hours of manual work!
为了文档目的，我需要从所有模块中提取所有过程名称，因此我采用了他的代码并将其改编成下面的函数，该函数检测我所有代码中的所有过程名称，包括表单和模块，然后将其存储到一个我的 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
回答by Mark Ronollo
Seriously? Why do developers continue to solve the same problem over and over again? Send get the procedure name into the Err object using Err.Raise...
严重地？为什么开发人员不断地一遍遍地解决同样的问题？使用 Err.Raise 将过程名称发送到 Err 对象中...
For the Source parameter pass in:
对于传入的 Source 参数：
Me.Name & "." & Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
I know it's not the shortest one liner but if you can't afford a commercial product to enhance the VBA IDE or if, like many of us, are restricted to working in a locked down environment then this is the easiest solution.
我知道这不是最短的一个班轮，但如果您买不起商业产品来增强 VBA IDE，或者如果像我们许多人一样仅限于在锁定的环境中工作，那么这是最简单的解决方案。
回答by sean hendrix
Code is ugly but it works. This example will add error handling code to each function that also contains a string with the function name.
代码很丑，但它有效。此示例将向每个还包含带有函数名称的字符串的函数添加错误处理代码。
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
