Get module (or/and) class, but also sub/function names ?

[Couin]

Hi friends,

I'm trying to "uniformise" my error handling syntax from one form to another, or from one module to another.

I explain.

I have a sub I call on each error:

Public Sub ErrorLog(sFunctionName As String)
...
End Sub

I call it like that :

ErrorLog "frmMain.CkAssign_Click"

where frmMain ist the form name, and CkAssign_Click the sub I want to write in the report generated by ErrorLog.

I have several forms so I changed for :

ErrorLog Me.Name & ".CkAssign_Click"

So rest me to change it for something to get the function/sub name and have a command like this
ErrorLog Me.Name & "." & sub_or_function_name

Also, "Me" runs only for forms. I would find something that can get the name of the "sheet" (Form, Module, Class..) so having a command like this :

ErrorLog Sheet_Name & "." & sub_or_function_name

I hope my explation is clear enough

Is it possible or not ?

Thanks

[dilettante]

Make an investment: VB Watch v2: Profiler, Protector and Debugger for VB6.

I doubt there are many more good ones on the market at this late date.

[Niya]

Make an investment: VB Watch v2: Profiler, Protector and Debugger for VB6.

I doubt there are many more good ones on the market at this late date.

I don't think that is what he is looking for. Here is a VB.Net example of what I believe he is looking for:-

Imports System.Reflection

Public Class Form1
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load

        Dim tb As TextBox

        Try
            'This will throw an exception
            tb.Text = "Hi"
        Catch ex As Exception

            'Catch the exception and log the error
            'We only need to pass the error message. LogError
            'will take care of figuring out where the error occurred
            'automatically
            LogError(ex.Message)

        End Try


    End Sub

    Private Sub LogError(ByVal message As String)
        Dim st As New StackTrace

        'Get all information about the sub or function that called
        'this sub
        Dim callingMethgod = st.GetFrame(1).GetMethod

        Debug.WriteLine($"Error occured in '{callingMethgod.Name}' member of type '{callingMethgod.DeclaringType.Name}'")
        Debug.WriteLine($"Error message : {message}")

    End Sub

End Class

The above code would produce this output:-

Error occured in 'Form1_Load' member of type 'Form1'
Error message : Object reference not set to an instance of an object.

The information in red about the method where the error occurred and and the class that contains the method was obtained automatically. I think this is what he is looking for, a way to generalize the logging code by having it automatically figure out where the error occurred and log it.

Unfortunately, I do not believe that this is even possible in VB6. As far as I know VB6 doesn't have the reflective capabilities to achieve something like this.

However, I have been surprised before. Perhaps the trick or Olaf know a way to do this in VB6.

[Couin]

Hi dilettante,

Thanks for answer
I bookmark the link.

In fact, the ErrorLog function is just for loging error in a errors.txt file when occurs on app running on the user machine.

I use it like that, for example, in a Sub :

Public Sub clTouchStop(btNum As Integer, Butt As CheckBox)

1       On Error GoTo Error_Routine

2       Jing(btNum).OnAir = False       'NO AUTOREPEAT = STOP
3       Call BASS_ChannelStop(Jing(btNum).Strm)
4       Call BASS_ChannelSetPosition(Jing(btNum).Strm, 0, BASS_POS_BYTE)
5       Butt.Value = vbUnchecked
6       Butt.BackColor = vbButtonFace

Exit_Routine:
7         Exit Sub
Error_Routine:
8         Debug.Assert False
9         ErrorLog "modClick.clTouchStop"
End Sub

As well as I havage several modules, forms, and functions/subs, I would have a "standard" line 9 like this :

ErrorLog Sheet_Name & "." & sub_or_function_name

It's not a critical point, if syntax exists, good thing... if not, that's life

Edit : @Niya sorry, I was writing while you answered

[argen]

So rest me to change it for something to get the function/sub name and have a command like this
ErrorLog Me.Name & "." & sub_or_function_name

Is it possible or not ?

Unfortunately it is not possible.
The only way is to write the string.

Perhaps an add-in could automate that, but from the code itself there is no way to get the procedure name (specially compiled and for private procedures).

[argen]

However, I have been surprised before. Perhaps the trick or Olaf know a way to do this in VB6.

The names of private procedures are nowhere in the compiled binary.
Also related (or exactly the same thing).

[fafalone]

What you could do is use an addin that generates it for each function in a single click for each.

AxTools CodeSMART can be used to define a default error handler, e.g.

On Error GoTo {MemberName}_Err


Exit {MemberType}

{MemberName}_Err:
    ErrorLog "{ComponentName}.{MemberName}.Error->" & Err.Description & ", 0x" & Hex$(Err.Number)

Then if you have, in Form1,

Private Function ItemName() As Long

(code)

End Function

and click insert, it would change it into

Private Function ItemName() As Long
'<EhHeader>
On Error GoTo ItemName_Err
'</EhHeader>

(code)

'<EhFooter>
Exit Function

ItemName_Err:
    ErrorLog "Form1.ItemName.Error->" & Err.Description & ", 0x" & Hex$(Err.Number)
'</EhFooter>
End Function

It's got a number of additional variables, including project name, and control name, and you can define different defaults for different object types (Form, UserControl, etc), as well as different handlers you can define you can insert from the full menu.

The only annoying part is there's nothing you can do to stop it from inserting those pointless header and footer tags, but you can run a replace all to get rid of them all at once later.

[Zvoni]

As a workaround (and i've seen it in use):
You have a global, dynamic Array of Strings

'Somewhere "global"
Public MyStringArray() As String

in modMain

'In Your Main Sub you intialize this Array
Private Const ModuleName As String ="modMain"

Public Sub Main()
Const Index As Long = 0
Redim Preserve MyStringArray(0 To Index)
MyStringArray(Index)=ModuleName & ".Main"
Call FirstForm 'etc.
End Sub

Now, in each Function, Sub, Procedure anywhere (Form, Module, Class), you have the Following:
Important: The Const in each Function (Sub etc.) must have a project-wide unique value, but always the same name! (in this Sample "Index")

'In Class myClass
Private Const ClassName as String = "MyClass"  'FormName, ModuleName etc.

Public Function SomeFunction(ByVal AValue As Long) As Long
'The First three lines would always be the same in each Procedure except the value for the Const
Const Index As Long = 1
IF UBound(MyStringArray)<Index Then Redim Preserve MyStringArray(0 To Index)
MyStringArray(Index)=ClassName & ".SomeFunction"
On Error Goto ErrorHandler
'Do heavy stuff which can go wrong

ErrorHandler:
ErrLog MyStringArray(Index)  'Now you can use this line everywhere
End Function

Beware: This is a very stripped down sample with no Error-Handling for the Array etc.

[wqweto]

Is it possible or not ?

Not possible in VB6.

I always declare Private Const MODULE_NAME As String = "frmMain" near the top of the module and Const FUNC_NAME As String = "CkAssign_Click" at the beginning of the routine so my error handling code is always ErrorLog MODULE_NAME & "." & FUNC_NAME in your parlance.

This is the simplest most hassle-free way of doing it.

There is slim chance that TwinBasic might predeclare similar consts at the compiler level the way most C/C++ compilers have __FILE__, __FUNCTION__ and __LINE__ predeclared defines.

cheers,
</wqw>

[WaynePhillipsEA]

vbWatchdog can provide you with that information, provided you are willing to compile your VB6 project to p-code:
https://www.everythingaccess.com/vbwatchdog.asp

It is primarily designed for VBA, but works also for VB6 projects in p-code mode.

(disclaimer: I am the developer of vbWatchdog, and it is a commercial tool)

[Niya]

provided you are willing to compile your VB6 project to p-code:

Come to think of it, in 2022 no one should have a problem with this requirement. The unparalleled success of Python has proven that native code performance is overrated in todays world. It only matters to people tinkering in the bowels of backend development. Most of us spent most of our time writing front end code that call into libraries that have been consistently super optimized over very long periods of time by people way smarter than us. For example, web servers, XML and HTML parsers, zip compression, common image related functionality like loading from and saving to different image formats are just a few examples of things that are performance sensitive that we don't write ourselves. We just use libraries provided by people who have dedicated decades of their lives to perfecting them.

[Niya]

Not possible in VB6.

I always declare Private Const MODULE_NAME As String = "frmMain" near the top of the module and Const FUNC_NAME As String = "CkAssign_Click" at the beginning of the routine so my error handling code is always ErrorLog MODULE_NAME & "." & FUNC_NAME in your parlance.

This is the simplest most hassle-free way of doing it.

There is slim chance that TwinBasic might predeclare similar consts at the compiler level the way most C/C++ compilers have __FILE__, __FUNCTION__ and __LINE__ predeclared defines.

cheers,
</wqw>

Reading this post actually gave me an idea, that this could all be automated. One could write a program to insert this into all their VB6 code automatically. You could use a very naïve parser to figure out the names of modules, classes, subs etc and insert the constant declarations using that data.

[The trick]

You can use EbGetCallstackCount/EbGetCallstackFunction in IDE. You can use a PDB file in the release executable.

[fafalone]

I've seen EbGetCallstack for the IDE, but how would you implement it for a pdb?

There's the DIA SDK; but then you'd have to install it on target systems too.

[Arnoutdv]

I use MZTools (v3) for this.
Just a click in the menu when in a routine and code will be inserted based on a template much like AxTools CodeSMART
The template I use:

  On Error GoTo Proc_Error
  'DebugLog ">> {PROCEDURE_TYPE} {PROCEDURE_NAME}() of {MODULE_TYPE} {MODULE_NAME}" 

	{PROCEDURE_BODY}

  GoTo Proc_Finish

Proc_Error:
  'If g_bInIDE Then Debug.Assert False: Resume
  DebugLog "Error: " & Err.Number & " on line: " & Erl & vbLf & _
           "Description: " & Err.Description & vbLf & _
           "in {PROCEDURE_TYPE} {PROCEDURE_NAME}() of {MODULE_TYPE} {MODULE_NAME}", True

Proc_Finish:
  'DebugLog "<< {PROCEDURE_TYPE} {PROCEDURE_NAME}() of {MODULE_TYPE} {MODULE_NAME}" 
  On Error GoTo 0

Which then generated the following code:

Private Sub Form_Load()

  On Error GoTo Proc_Error
  'DebugLog ">> Sub Form_Load() of Form Form1"

  GoTo Proc_Finish

Proc_Error:
  'If g_bInIDE Then Debug.Assert False: Resume
  DebugLog "Error: " & Err.Number & " on line: " & Erl & vbLf & _
           "Description: " & Err.Description & vbLf & _
           "in Sub Form_Load() of Form Form1", True

Proc_Finish:
  'DebugLog "<< Sub Form_Load() of Form Form1"
  On Error GoTo 0
End Sub

[The trick]

I've seen EbGetCallstack for the IDE, but how would you implement it for a pdb?

There's the DIA SDK; but then you'd have to install it on target systems too.

' //
' // Get calling procedure name
' // The result executable should be compiled with debug symbols
' // by The trick 2022
' //

Option Explicit
Option Base 0

Private Enum PTR    ' // Alias (thanks OlimilO1402)
    [_]
End Enum

Private Const MAX_SYM_NAME                                  As Long = 2000
Private Const MAX_PATH                                      As Long = 260
Private Const SIZEOF_SYMBOL_INFO                            As Long = 88
Private Const GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS        As Long = 4
Private Const GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT  As Long = 2

Private Type SYMBOL_INFO
    SizeOfStruct            As Long
    TypeIndex               As Long
    Reserved(1)             As Currency
    Index                   As Long
    Size                    As Long
    ModBase                 As Currency
    Flags                   As Long
    lPad0                   As Long
    Value                   As Currency
    Address                 As Currency
    Register                As Long
    Scope                   As Long
    Tag                     As Long
    NameLen                 As Long
    MaxNameLen              As Long
    iName(MAX_SYM_NAME - 1) As Integer
End Type

Private Declare Function SymInitialize Lib "dbghelp" _
                         Alias "SymInitializeW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal UserSearchPath As Any, _
                         ByVal fInvadeProcess As Long) As Long
Private Declare Function SymFromAddr Lib "dbghelp" _
                         Alias "SymFromAddrW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal Address As Currency, _
                         ByRef Displacement As Currency, _
                         ByRef Symbol As SYMBOL_INFO) As Long
Private Declare Function SymLoadModuleEx Lib "dbghelp" _
                         Alias "SymLoadModuleExW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal hFile As OLE_HANDLE, _
                         ByVal ImageName As PTR, _
                         ByVal ModuleName As PTR, _
                         ByVal BaseOfDll As Currency, _
                         ByVal DllSize As Long, _
                         ByRef Data As Any, _
                         ByVal Flags As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" _
                         Alias "GetModuleFileNameW" ( _
                         ByVal hModule As Long, _
                         ByVal lpFileName As PTR, _
                         ByVal nSize As Long) As Long
Private Declare Function GetModuleHandleEx Lib "kernel32" _
                         Alias "GetModuleHandleExW" ( _
                         ByVal dwFlags As Long, _
                         ByVal lpModuleName As PTR, _
                         ByRef phModule As Any) As Long
Private Declare Function SysAllocString Lib "oleaut32" ( _
                         ByRef pOlechar As Any) As Long
Private Declare Function EbSetMode Lib "vba6" ( _
                         ByVal Mode As Long) As Long
Private Declare Function EbGetCallstackCount Lib "vba6" ( _
                         ByRef lCount As Long) As Long
Private Declare Function EbGetCallstackFunction Lib "vba6" ( _
                         ByVal lIndex As Long, _
                         ByVal pProject As PTR, _
                         ByVal pModule As PTR, _
                         ByVal pFunction As PTR, _
                         ByRef lRet As Long) As Long
    
Private Declare Sub GetMem4 Lib "msvbvm60" ( _
                    ByRef pAddr As Any, _
                    ByRef pRetVal As Any)
Private Declare Sub PutMemPtr Lib "msvbvm60" _
                    Alias "PutMem4" ( _
                    ByRef pAddr As Any, _
                    ByVal pNewVal As PTR)

Private m_bInintialized As Boolean

Public Function GetCallingProcName( _
                Optional ByVal lReserved As Long) As String
    Dim tSymInfo    As SYMBOL_INFO
    Dim cAddr       As Currency
    Dim cDisp       As Currency
    Dim bIsInIDE    As Boolean
    Dim lStackCount As Long
    Dim sProject    As String
    Dim sModule     As String
    Dim sFunction   As String
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
        
        EbSetMode 2
        
        If EbGetCallstackCount(lStackCount) >= 0 Then
            If lStackCount > 1 Then
                If EbGetCallstackFunction(1, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
                    GetCallingProcName = sModule & "::" & sFunction
                End If
            End If
        End If
        
        EbSetMode 1
        
        Exit Function
        
    End If
    
    If Not m_bInintialized Then
        If SymInitialize(VarPtr(m_bInintialized), ByVal 0&, 0) = 0 Then
            Exit Function
        ElseIf SymLoadModuleEx(VarPtr(m_bInintialized), 0, StrPtr(GetExecutableName), 0, 0@, 0, ByVal 0&, 0) = 0 Then
            Exit Function
        Else
            m_bInintialized = True
        End If
    End If
    
    tSymInfo.SizeOfStruct = SIZEOF_SYMBOL_INFO
    tSymInfo.MaxNameLen = MAX_SYM_NAME
    
    GetMem4 ByVal VarPtr(lReserved) - 4, cAddr
    
    If SymFromAddr(VarPtr(m_bInintialized), cAddr, cDisp, tSymInfo) = 0 Then
        Exit Function
    End If
    
    PutMemPtr ByVal VarPtr(GetCallingProcName), SysAllocString(tSymInfo.iName(0))
    
End Function

Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function

Private Function GetExecutableName() As String
    Dim sRet    As String
    Dim lSize   As Long
    Dim hMod    As PTR
    
    If GetModuleHandleEx(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS Or GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, _
                         AddressOf GetCallingProcName, hMod) = 0 Then
        Exit Function
    End If
    
    sRet = Space$(MAX_PATH)
    lSize = GetModuleFileName(hMod, StrPtr(sRet), Len(sRet))
    
    If lSize Then
        GetExecutableName = Left$(sRet, lSize)
    End If

End Function

Usage

MsgBox GetCallingProcName

[Niya]

' //
' // Get calling procedure name
' // The result executable should be compiled with debug symbols
' // by The trick 2022
' //

Option Explicit
Option Base 0

Private Enum PTR    ' // Alias (thanks OlimilO1402)
    [_]
End Enum

Private Const MAX_SYM_NAME                                  As Long = 2000
Private Const MAX_PATH                                      As Long = 260
Private Const SIZEOF_SYMBOL_INFO                            As Long = 88
Private Const GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS        As Long = 4
Private Const GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT  As Long = 2

Private Type SYMBOL_INFO
    SizeOfStruct            As Long
    TypeIndex               As Long
    Reserved(1)             As Currency
    Index                   As Long
    Size                    As Long
    ModBase                 As Currency
    Flags                   As Long
    lPad0                   As Long
    Value                   As Currency
    Address                 As Currency
    Register                As Long
    Scope                   As Long
    Tag                     As Long
    NameLen                 As Long
    MaxNameLen              As Long
    iName(MAX_SYM_NAME - 1) As Integer
End Type

Private Declare Function SymInitialize Lib "dbghelp" _
                         Alias "SymInitializeW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal UserSearchPath As Any, _
                         ByVal fInvadeProcess As Long) As Long
Private Declare Function SymFromAddr Lib "dbghelp" _
                         Alias "SymFromAddrW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal Address As Currency, _
                         ByRef Displacement As Currency, _
                         ByRef Symbol As SYMBOL_INFO) As Long
Private Declare Function SymLoadModuleEx Lib "dbghelp" _
                         Alias "SymLoadModuleExW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal hFile As OLE_HANDLE, _
                         ByVal ImageName As PTR, _
                         ByVal ModuleName As PTR, _
                         ByVal BaseOfDll As Currency, _
                         ByVal DllSize As Long, _
                         ByRef Data As Any, _
                         ByVal Flags As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" _
                         Alias "GetModuleFileNameW" ( _
                         ByVal hModule As Long, _
                         ByVal lpFileName As PTR, _
                         ByVal nSize As Long) As Long
Private Declare Function GetModuleHandleEx Lib "kernel32" _
                         Alias "GetModuleHandleExW" ( _
                         ByVal dwFlags As Long, _
                         ByVal lpModuleName As PTR, _
                         ByRef phModule As Any) As Long
Private Declare Function SysAllocString Lib "oleaut32" ( _
                         ByRef pOlechar As Any) As Long
Private Declare Function EbSetMode Lib "vba6" ( _
                         ByVal Mode As Long) As Long
Private Declare Function EbGetCallstackCount Lib "vba6" ( _
                         ByRef lCount As Long) As Long
Private Declare Function EbGetCallstackFunction Lib "vba6" ( _
                         ByVal lIndex As Long, _
                         ByVal pProject As PTR, _
                         ByVal pModule As PTR, _
                         ByVal pFunction As PTR, _
                         ByRef lRet As Long) As Long
    
Private Declare Sub GetMem4 Lib "msvbvm60" ( _
                    ByRef pAddr As Any, _
                    ByRef pRetVal As Any)
Private Declare Sub PutMemPtr Lib "msvbvm60" _
                    Alias "PutMem4" ( _
                    ByRef pAddr As Any, _
                    ByVal pNewVal As PTR)

Private m_bInintialized As Boolean

Public Function GetCallingProcName( _
                Optional ByVal lReserved As Long) As String
    Dim tSymInfo    As SYMBOL_INFO
    Dim cAddr       As Currency
    Dim cDisp       As Currency
    Dim bIsInIDE    As Boolean
    Dim lStackCount As Long
    Dim sProject    As String
    Dim sModule     As String
    Dim sFunction   As String
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
        
        EbSetMode 2
        
        If EbGetCallstackCount(lStackCount) >= 0 Then
            If lStackCount > 1 Then
                If EbGetCallstackFunction(1, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
                    GetCallingProcName = sModule & "::" & sFunction
                End If
            End If
        End If
        
        EbSetMode 1
        
        Exit Function
        
    End If
    
    If Not m_bInintialized Then
        If SymInitialize(VarPtr(m_bInintialized), ByVal 0&, 0) = 0 Then
            Exit Function
        ElseIf SymLoadModuleEx(VarPtr(m_bInintialized), 0, StrPtr(GetExecutableName), 0, 0@, 0, ByVal 0&, 0) = 0 Then
            Exit Function
        Else
            m_bInintialized = True
        End If
    End If
    
    tSymInfo.SizeOfStruct = SIZEOF_SYMBOL_INFO
    tSymInfo.MaxNameLen = MAX_SYM_NAME
    
    GetMem4 ByVal VarPtr(lReserved) - 4, cAddr
    
    If SymFromAddr(VarPtr(m_bInintialized), cAddr, cDisp, tSymInfo) = 0 Then
        Exit Function
    End If
    
    PutMemPtr ByVal VarPtr(GetCallingProcName), SysAllocString(tSymInfo.iName(0))
    
End Function

Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function

Private Function GetExecutableName() As String
    Dim sRet    As String
    Dim lSize   As Long
    Dim hMod    As PTR
    
    If GetModuleHandleEx(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS Or GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, _
                         AddressOf GetCallingProcName, hMod) = 0 Then
        Exit Function
    End If
    
    sRet = Space$(MAX_PATH)
    lSize = GetModuleFileName(hMod, StrPtr(sRet), Len(sRet))
    
    If lSize Then
        GetExecutableName = Left$(sRet, lSize)
    End If

End Function

Usage

MsgBox GetCallingProcName

Amazing piece of code as usual. However, I do have a question, can this be altered to pick any method off the call stack or can it only do the current method?

The reason I ask is that when I do the kind of thing OP is doing in .Net, I usually resolve the method from within the log function itself as opposed to resolving it and passing it in. So instead of:-

LogError GetCallingProcName

I'd do:-

LogError

And the LogError function itself will walk one frame up the call stack to get the name of the method that called it.

[The trick]

You can walk through call stack using RtlCaptureStackBackTrace function like:

Private Declare Function RtlCaptureStackBackTrace Lib "kernel32" ( _
                         ByVal FramesToSkip As Long, _
                         ByVal FramesToCapture As Long, _
                         ByRef BackTrace As Any, _
                         ByRef BackTraceHash As Any) As Integer

Private Sub Form_Load()
    Dim lPtrs() As Long
    
    ReDim lPtrs(10)
    
    RtlCaptureStackBackTrace 0, UBound(lPtrs) + 1, lPtrs(0), ByVal 0&
    
End Sub

But you don't need this if you need a function like LogError. Just copy code from GetCallingProcName to your function and add your logic inside this function. Of course you could using RtlCaptureStackBackTrace and get the all call stack like:

Public Function GetCallStack() As String
    Dim tSymInfo    As SYMBOL_INFO
    Dim cAddr       As Currency
    Dim cDisp       As Currency
    Dim bIsInIDE    As Boolean
    Dim lStackCount As Long
    Dim sProject    As String
    Dim sModule     As String
    Dim sFunction   As String
    Dim lIndex      As Long
    Dim pAddr()     As PTR
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
        
        EbSetMode 2
        
        If EbGetCallstackCount(lStackCount) >= 0 Then
            For lIndex = 1 To lStackCount - 1
                If EbGetCallstackFunction(lIndex, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
                
                    GetCallStack = GetCallStack & sModule & "::" & sFunction & vbNewLine
                    sProject = vbNullString
                    sModule = vbNullString
                    sFunction = vbNullString
                    
                End If
            Next
        End If
        
        EbSetMode 1
        
        Exit Function
        
    End If
    
    If Not m_bInintialized Then
        If SymInitialize(VarPtr(m_bInintialized), ByVal 0&, 0) = 0 Then
            Exit Function
        ElseIf SymLoadModuleEx(VarPtr(m_bInintialized), 0, StrPtr(GetExecutableName), 0, 0@, 0, ByVal 0&, 0) = 0 Then
            Exit Function
        Else
            m_bInintialized = True
        End If
    End If
    
    tSymInfo.SizeOfStruct = SIZEOF_SYMBOL_INFO
    tSymInfo.MaxNameLen = MAX_SYM_NAME
    
    ReDim pAddr(31)
    
    lStackCount = RtlCaptureStackBackTrace(1, UBound(pAddr) + 1, pAddr(0), ByVal 0&)
    
    For lIndex = 0 To UBound(pAddr)
    
        GetMem4 pAddr(lIndex), cAddr
    
        If SymFromAddr(VarPtr(m_bInintialized), cAddr, cDisp, tSymInfo) Then
            
            PutMemPtr ByVal VarPtr(sFunction), SysAllocString(tSymInfo.iName(0))
            GetCallStack = GetCallStack & sFunction & vbNewLine
            sFunction = vbNullString
            
        Else
            
            GetCallStack = GetCallStack & "<unknown>" & vbNewLine
            
        End If

    Next
    
End Function

[argen]

The issue is that it only works in the IDE

[The trick]

The issue is that it only works in the IDE

Do you compile with the debug symbols?

[argen]

Do you compile with the debug symbols?

Sorry, I didn't understand that I had to do that.
Yes, it works now. Amazing!

[loquat]

' //
' // Get calling procedure name
' // The result executable should be compiled with debug symbols
' // by The trick 2022
' //

Option Explicit
Option Base 0

Private Enum PTR    ' // Alias (thanks OlimilO1402)
    [_]
End Enum

Private Const MAX_SYM_NAME                                  As Long = 2000
Private Const MAX_PATH                                      As Long = 260
Private Const SIZEOF_SYMBOL_INFO                            As Long = 88
Private Const GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS        As Long = 4
Private Const GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT  As Long = 2

Private Type SYMBOL_INFO
    SizeOfStruct            As Long
    TypeIndex               As Long
    Reserved(1)             As Currency
    Index                   As Long
    Size                    As Long
    ModBase                 As Currency
    Flags                   As Long
    lPad0                   As Long
    Value                   As Currency
    Address                 As Currency
    Register                As Long
    Scope                   As Long
    Tag                     As Long
    NameLen                 As Long
    MaxNameLen              As Long
    iName(MAX_SYM_NAME - 1) As Integer
End Type

Private Declare Function SymInitialize Lib "dbghelp" _
                         Alias "SymInitializeW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal UserSearchPath As Any, _
                         ByVal fInvadeProcess As Long) As Long
Private Declare Function SymFromAddr Lib "dbghelp" _
                         Alias "SymFromAddrW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal Address As Currency, _
                         ByRef Displacement As Currency, _
                         ByRef Symbol As SYMBOL_INFO) As Long
Private Declare Function SymLoadModuleEx Lib "dbghelp" _
                         Alias "SymLoadModuleExW" ( _
                         ByVal hProcess As OLE_HANDLE, _
                         ByVal hFile As OLE_HANDLE, _
                         ByVal ImageName As PTR, _
                         ByVal ModuleName As PTR, _
                         ByVal BaseOfDll As Currency, _
                         ByVal DllSize As Long, _
                         ByRef Data As Any, _
                         ByVal Flags As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" _
                         Alias "GetModuleFileNameW" ( _
                         ByVal hModule As Long, _
                         ByVal lpFileName As PTR, _
                         ByVal nSize As Long) As Long
Private Declare Function GetModuleHandleEx Lib "kernel32" _
                         Alias "GetModuleHandleExW" ( _
                         ByVal dwFlags As Long, _
                         ByVal lpModuleName As PTR, _
                         ByRef phModule As Any) As Long
Private Declare Function SysAllocString Lib "oleaut32" ( _
                         ByRef pOlechar As Any) As Long
Private Declare Function EbSetMode Lib "vba6" ( _
                         ByVal Mode As Long) As Long
Private Declare Function EbGetCallstackCount Lib "vba6" ( _
                         ByRef lCount As Long) As Long
Private Declare Function EbGetCallstackFunction Lib "vba6" ( _
                         ByVal lIndex As Long, _
                         ByVal pProject As PTR, _
                         ByVal pModule As PTR, _
                         ByVal pFunction As PTR, _
                         ByRef lRet As Long) As Long
    
Private Declare Sub GetMem4 Lib "msvbvm60" ( _
                    ByRef pAddr As Any, _
                    ByRef pRetVal As Any)
Private Declare Sub PutMemPtr Lib "msvbvm60" _
                    Alias "PutMem4" ( _
                    ByRef pAddr As Any, _
                    ByVal pNewVal As PTR)

Private m_bInintialized As Boolean

Public Function GetCallingProcName( _
                Optional ByVal lReserved As Long) As String
    Dim tSymInfo    As SYMBOL_INFO
    Dim cAddr       As Currency
    Dim cDisp       As Currency
    Dim bIsInIDE    As Boolean
    Dim lStackCount As Long
    Dim sProject    As String
    Dim sModule     As String
    Dim sFunction   As String
    
    Debug.Assert MakeTrue(bIsInIDE)
    
    If bIsInIDE Then
        
        EbSetMode 2
        
        If EbGetCallstackCount(lStackCount) >= 0 Then
            If lStackCount > 1 Then
                If EbGetCallstackFunction(1, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
                    GetCallingProcName = sModule & "::" & sFunction
                End If
            End If
        End If
        
        EbSetMode 1
        
        Exit Function
        
    End If
    
    If Not m_bInintialized Then
        If SymInitialize(VarPtr(m_bInintialized), ByVal 0&, 0) = 0 Then
            Exit Function
        ElseIf SymLoadModuleEx(VarPtr(m_bInintialized), 0, StrPtr(GetExecutableName), 0, 0@, 0, ByVal 0&, 0) = 0 Then
            Exit Function
        Else
            m_bInintialized = True
        End If
    End If
    
    tSymInfo.SizeOfStruct = SIZEOF_SYMBOL_INFO
    tSymInfo.MaxNameLen = MAX_SYM_NAME
    
    GetMem4 ByVal VarPtr(lReserved) - 4, cAddr
    
    If SymFromAddr(VarPtr(m_bInintialized), cAddr, cDisp, tSymInfo) = 0 Then
        Exit Function
    End If
    
    PutMemPtr ByVal VarPtr(GetCallingProcName), SysAllocString(tSymInfo.iName(0))
    
End Function

Private Function MakeTrue( _
                 ByRef bValue As Boolean) As Boolean
    MakeTrue = True
    bValue = True
End Function

Private Function GetExecutableName() As String
    Dim sRet    As String
    Dim lSize   As Long
    Dim hMod    As PTR
    
    If GetModuleHandleEx(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS Or GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, _
                         AddressOf GetCallingProcName, hMod) = 0 Then
        Exit Function
    End If
    
    sRet = Space$(MAX_PATH)
    lSize = GetModuleFileName(hMod, StrPtr(sRet), Len(sRet))
    
    If lSize Then
        GetExecutableName = Left$(sRet, lSize)
    End If

End Function

Usage

MsgBox GetCallingProcName

it seems has a bug?
when call it in IDE, the cursor always jump to the subrotine GetCallingProcName
in my IDE the line: EbSetMode 2