Get Name of Current VBA Function

The code of sean hendrix is not bad at all. I improved it a little bit:

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.

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

Mark Ronollo's solution works like a charm.

I had the need to extract all procedure names from all modules 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!

    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

We created a table named "Error Debug Log" that holds the error info, create a date field that the default field is Now() (to auto-polulate the date it happened) and another text field to hold the name of the Function.

Create a public function to add records when it fails:

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

Then Call it when the error happens, we find this to be easier so the info is in a table that we can examine later.

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

If you are going to spend time assigning a value to variable with the name of the function, this is just easier to write the name whenever you need it.