-
Get module (or/and) class, but also sub/function names ?
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:
Code:
Public Sub ErrorLog(sFunctionName As String)
...
End Sub
I call it like that :
Code:
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 :
Code:
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 :
Code:
ErrorLog Sheet_Name & "." & sub_or_function_name
I hope my explation is clear enough :blush:
Is it possible or not ?
Thanks
-
Re: Get module (or/and) class, but also sub/function names ?
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.
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
dilettante
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:-
Code:
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:-
Code:
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.
-
Re: Get module (or/and) class, but also sub/function names ?
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 :
Code:
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 :
Code:
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 ;)
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
Couin
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).
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
Niya
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).
-
Re: Get module (or/and) class, but also sub/function names ?
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.
Code:
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,
Code:
Private Function ItemName() As Long
(code)
End Function
and click insert, it would change it into
Code:
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.
-
Re: Get module (or/and) class, but also sub/function names ?
As a workaround (and i've seen it in use):
You have a global, dynamic Array of Strings
Code:
'Somewhere "global"
Public MyStringArray() As String
in modMain
Code:
'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")
Code:
'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.
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
Couin
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>
-
Re: Get module (or/and) class, but also sub/function names ?
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)
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
WaynePhillipsEA
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.
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
wqweto
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.
-
Re: Get module (or/and) class, but also sub/function names ?
You can use EbGetCallstackCount/EbGetCallstackFunction in IDE. You can use a PDB file in the release executable.
-
Re: Get module (or/and) class, but also sub/function names ?
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.
-
Re: Get module (or/and) class, but also sub/function names ?
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:
Code:
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:
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
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
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.
Code:
' //
' // 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
Code:
MsgBox GetCallingProcName
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
The trick
Code:
' //
' // 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
Code:
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:-
Code:
LogError GetCallingProcName
I'd do:-
And the LogError function itself will walk one frame up the call stack to get the name of the method that called it.
-
Re: Get module (or/and) class, but also sub/function names ?
You can walk through call stack using RtlCaptureStackBackTrace function like:
Code:
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:
Code:
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
-
Re: Get module (or/and) class, but also sub/function names ?
The issue is that it only works in the IDE
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
argen
The issue is that it only works in the IDE
Do you compile with the debug symbols?
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
The trick
Do you compile with the debug symbols?
Sorry, I didn't understand that I had to do that.
Yes, it works now. Amazing!
-
Re: Get module (or/and) class, but also sub/function names ?
Quote:
Originally Posted by
The trick
Code:
' //
' // 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
Code:
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
