VB6 call-stack capture via dbghelp.dll (32-bit StackWalk + Unicode symbol APIs)

This module produces call-stacks with parameters peeked based on their types being surmised from the names w/ hungarian notation (heh) like this:

Code:

---

Project1.exe!Form1::pvProcess Line 38  Me=&H6FDD00->&H40543C, sText="Test", sTest2=&H1AFA74->"Proba", lOffset=&H2A, Cancel=&H1AFA70->&H0
Project1.exe!Form1::Command1_Click Line 29  Me=&H6FDD00->&H40543C
Project1.exe!Form1::Form_Load Line 34  Me=&H6FDD00->&H40543C
MSVBVM60.DLL!Zombie_QueryInterface + &H7E3
MSVBVM60.DLL!Zombie_QueryInterface + &H7C0
MSVBVM60.DLL!_vbaRedimPreserve + &H176B
MSVBVM60.DLL!_vbaVarCat + &H105E
MSVBVM60.DLL!EVENT_SINK_Release + &H10A5
MSVBVM60.DLL!EVENT_SINK_Release + &HF20
MSVBVM60.DLL!EVENT_SINK_Release + &HEB4
MSVBVM60.DLL!rtcVarType + &H317
MSVBVM60.DLL!EbLoadRunTime + &HA22
MSVBVM60.DLL!EbSetContextWorkerThread + &H6EE
MSVBVM60.DLL!EbLibraryLoad + &H4DC
MSVBVM60.DLL!ThunRTMain + &H155
MSVBVM60.DLL!ThunRTMain + &H5B
Project1.exe!__vbaS + &HA
ntdll.dll!RtlInitializeExceptionChain + &H6B
ntdll.dll!RtlGetAppContainerNamedObjectPath + &H231

---

Here is the Claude assisted helper module with all of the boring comments stripped:

Code:

---

'=== mdCallStack.bas =======================================================
' VB6 call-stack capture via dbghelp.dll (32-bit StackWalk + Unicode symbol APIs).
'
' Requires:  Native code compile + "Create Symbolic Debug Info" (Project ->
'            Properties -> Compile).  The resulting .pdb must sit next to the
'            .exe/.dll.  Ship a known-good dbghelp.dll alongside the app.
'
' Output mimics the IDE call-stack view, one frame per line:
'  Module.ext!Class::Method Line 123          (when source line is known)
'  Module.dll!Export + &H1A                    (no PDB -> symbol + displacement)
'===========================================================================
Option Explicit
DefObj A-Z

Private Const MACHINE_I386              As Long = &H14C
Private Const ADDRMODE_FLAT              As Long = 3
Private Const CONTEXT_FULL              As Long = &H10007  '--- CONTROL|INTEGER|SEGMENTS
Private Const SYMOPT_LOAD_LINES          As Long = &H10
Private Const SYMOPT_DEFERRED            As Long = &H4
Private Const SYMOPT_UNDNAME            As Long = &H2
Private Const MAX_NAME                  As Long = 511
Private Const MAX_PATH                  As Long = 260
Private Const MAX_STR_DUMP              As Long = 1024
Private Const SYMFLAG_VALUEPRESENT      As Long = &H1
Private Const SYMFLAG_REGREL            As Long = &H10
Private Const SYMFLAG_FRAMEREL          As Long = &H20
Private Const SYMFLAG_PARAMETER          As Long = &H40
Private Const CV_REG_EBP                As Long = 22
Private Const CV_ALLREG_VFRAME          As Long = 30006

Private Type ADDRESS32
    Offset                  As Long
    Segment                As Integer
    Pad                    As Integer
    Mode                    As Long
End Type

Private Type STACKFRAME
    AddrPC                  As ADDRESS32
    AddrReturn              As ADDRESS32
    AddrFrame              As ADDRESS32
    AddrStack              As ADDRESS32
    FuncTblEntry            As Long
    Params(0 To 3)          As Long
    fFar                    As Long
    fVirtual                As Long
    Reserved(0 To 2)        As Long
    KdHelp(0 To 23)        As Long
End Type

Private Type FLOATING_SAVE_AREA
    ControlWord            As Long
    StatusWord              As Long
    TagWord                As Long
    ErrorOffset            As Long
    ErrorSelector          As Long
    DataOffset              As Long
    DataSelector            As Long
    RegisterArea(0 To 79)  As Byte
    Cr0NpxState            As Long
End Type

Private Type CAPTURE_CONTEXT
    ContextFlags            As Long
    Dr0                    As Long
    Dr1                    As Long
    Dr2                    As Long
    Dr3                    As Long
    Dr6                    As Long
    Dr7                    As Long
    FloatSave              As FLOATING_SAVE_AREA
    SegGs                  As Long
    SegFs                  As Long
    SegEs                  As Long
    SegDs                  As Long
    Edi                    As Long
    Esi                    As Long
    Ebx                    As Long
    Edx                    As Long
    Ecx                    As Long
    Eax                    As Long
    Ebp                    As Long
    Eip                    As Long
    SegCs                  As Long
    EFlags                  As Long
    Esp                    As Long
    SegSs                  As Long
    ExtendedRegisters(0 To 511) As Byte
End Type

Private Type IMAGEHLP_LINEW64
    SizeOfStruct            As Long      '---  0
    Key                    As Long      '---  4  PVOID
    LineNumber              As Long      '---  8
    FileName                As Long      '--- 12  PWSTR
    AddressLo              As Long      '--- 16  ULONG64 Address
    AddressHi              As Long      '--- 20
End Type

Private Type SYMBOL_INFOW
    SizeOfStruct            As Long      '---  0
    TypeIndex              As Long      '---  4
    Reserved(0 To 3)        As Long      '---  8  ULONG64 Reserved[2] (16 bytes)
    Index                  As Long      '--- 24
    SymSize                As Long      '--- 28
    ModBaseLo              As Long      '--- 32  ULONG64 ModBase
    ModBaseHi              As Long      '--- 36
    Flags                  As Long      '--- 40
    Pad44                  As Long      '--- 44  alignment pad before ULONG64 Value
    ValueLo                As Long      '--- 48  ULONG64 Value
    ValueHi                As Long      '--- 52
    AddressLo              As Long      '--- 56  ULONG64 Address (frame/reg-relative offset)
    AddressHi              As Long      '--- 60
    Register                As Long      '--- 64
    Scope                  As Long      '--- 68
    Tag                    As Long      '--- 72
    NameLen                As Long      '--- 76
    MaxNameLen              As Long      '--- 80
    NameBuf(0 To MAX_NAME)  As Integer  '--- 84  WCHAR Name[1] (variable length follows)
End Type

Private Type IMAGEHLP_STACK_FRAME
    InstructionOffsetLo    As Long      '---  0
    InstructionOffsetHi    As Long      '---  4
    ReturnOffsetLo          As Long      '---  8
    ReturnOffsetHi          As Long      '---  12
    FrameOffsetLo          As Long      '---  16
    FrameOffsetHi          As Long      '---  20
    StackOffsetLo          As Long      '---  24
    StackOffsetHi          As Long      '---  28
    BackingStoreOffsetLo    As Long      '---  32
    BackingStoreOffsetHi    As Long      '---  36
    FuncTableEntryLo        As Long      '---  40
    FuncTableEntryHi        As Long      '---  44
    Params(0 To 7)          As Long      '---  48  ULONG64 Params[4]
    Reserved(0 To 9)        As Long      '---  80  ULONG64 Reserved[5]
    Virtual                As Long      '--- 120  BOOL
    Reserved2              As Long      '--- 124  ULONG
End Type

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, ByVal cb As Long)
Private Declare Sub RtlCaptureContext Lib "kernel32" (ctx As CAPTURE_CONTEXT)
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameW" (ByVal hModule As Long, ByVal lpFilename As Long, ByVal nSize As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hMod As Long, ByVal lpProc As String) As Long
Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal cb As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, ByVal lpsz As Long) As Long
'--- dbghelp
Private Declare Function SymInitialize Lib "dbghelp" Alias "SymInitializeW" (ByVal hProc As Long, ByVal lpUserSearchPath As Long, ByVal fInvade As Long) As Long
Private Declare Function SymCleanup Lib "dbghelp" (ByVal hProc As Long) As Long
Private Declare Function SymSetOptions Lib "dbghelp" (ByVal opts As Long) As Long
Private Declare Function SymGetModuleBase Lib "dbghelp" (ByVal hProc As Long, ByVal dwAddr As Long) As Long
Private Declare Function StackWalk Lib "dbghelp" (ByVal MachineType As Long, ByVal hProc As Long, ByVal hThread As Long, sf As STACKFRAME, ctx As CAPTURE_CONTEXT, ByVal pfnRead As Long, ByVal pfnFTA As Long, ByVal pfnGMB As Long, ByVal pfnTranslate As Long) As Long
Private Declare Function SymFromAddr Lib "dbghelp" Alias "SymFromAddrW" (ByVal hProc As Long, ByVal AddressLo As Long, ByVal AddressHi As Long, Displacement As Currency, Symbol As Any) As Long
Private Declare Function SymGetLineFromAddr64 Lib "dbghelp" Alias "SymGetLineFromAddrW64" (ByVal hProc As Long, ByVal AddressLo As Long, ByVal AddressHi As Long, Displacement As Long, Line As IMAGEHLP_LINEW64) As Long
Private Declare Function SymSetContext Lib "dbghelp" (ByVal hProc As Long, pStackFrame As Any, ByVal ctx As Long) As Long
Private Declare Function SymEnumSymbols Lib "dbghelp" Alias "SymEnumSymbolsW" (ByVal hProc As Long, ByVal BaseOfDll As Currency, ByVal Mask As Long, ByVal pfnCallback As Long, ByVal UserContext As Long) As Long

Private Type EnumContext
    FrameEbp                As Long
    Params                  As String
End Type

Public Function GetPdbCallstack() As String
    Dim hProc          As Long
    Dim hThread        As Long
    Dim pfnFTA          As Long
    Dim pfnGMB          As Long
    Dim uCtx            As CAPTURE_CONTEXT
    Dim uFrame          As STACKFRAME
    Dim uScopeFrame    As IMAGEHLP_STACK_FRAME
    Dim uSym            As SYMBOL_INFOW
    Dim uLine          As IMAGEHLP_LINEW64
    Dim uEnumCtx        As EnumContext
    Dim cTemp          As Currency
    Dim lDisp          As Long
    Dim lLineDisp      As Long
    Dim sModule        As String
    Dim sName          As String
    Dim sFrame          As String
    Dim sOut            As String

    On Error GoTo EH
    hProc = GetCurrentProcess()
    hThread = GetCurrentThread()
    Call SymSetOptions(SYMOPT_LOAD_LINES Or SYMOPT_DEFERRED Or SYMOPT_UNDNAME)
    If SymInitialize(hProc, 0, 1) = 0 Then
        GetPdbCallstack = "SymInitialize failed (&H" & Hex$(Err.LastDllError) & ")"
        Exit Function
    End If
    pfnFTA = GetProcAddress(GetModuleHandle(StrPtr("dbghelp")), "SymFunctionTableAccess")
    pfnGMB = GetProcAddress(GetModuleHandle(StrPtr("dbghelp")), "SymGetModuleBase")
    uCtx.ContextFlags = CONTEXT_FULL
    Call RtlCaptureContext(uCtx)
    uFrame.AddrPC.Offset = uCtx.Eip
    uFrame.AddrPC.Mode = ADDRMODE_FLAT
    uFrame.AddrFrame.Offset = uCtx.Ebp
    uFrame.AddrFrame.Mode = ADDRMODE_FLAT
    uFrame.AddrStack.Offset = uCtx.Esp
    uFrame.AddrStack.Mode = ADDRMODE_FLAT
    Do While StackWalk(MACHINE_I386, hProc, hThread, uFrame, uCtx, 0, pfnFTA, pfnGMB, 0) <> 0
        If uFrame.AddrPC.Offset = 0 Then
            Exit Do
        End If
        sModule = pvModuleName(hProc, uFrame.AddrPC.Offset)
        uSym.SizeOfStruct = LenB(uSym) - 2 * (MAX_NAME - 1)
        uSym.MaxNameLen = MAX_NAME
        If SymFromAddr(hProc, uFrame.AddrPC.Offset, 0, cTemp, uSym) <> 0 Then
            sName = pvToString(VarPtr(uSym.NameBuf(0)))
            Call CopyMemory(lDisp, cTemp, 4)
        Else
            sName = vbNullString
        End If
        If LenB(sModule) <> 0 Then
            sFrame = sModule & "!"
        Else
            sFrame = vbNullString
        End If
        If LenB(sName) <> 0 Then
            sFrame = sFrame & sName
        Else
            sFrame = sFrame & "&H" & Hex$(uFrame.AddrPC.Offset)
        End If
        uLine.SizeOfStruct = LenB(uLine)
        If SymGetLineFromAddr64(hProc, uFrame.AddrPC.Offset, 0, lLineDisp, uLine) <> 0 Then
            sFrame = sFrame & " Line " & uLine.LineNumber
        ElseIf LenB(sName) <> 0 Then
            sFrame = sFrame & " + &H" & Hex$(lDisp)
        End If
        uScopeFrame.InstructionOffsetLo = uFrame.AddrPC.Offset
        uScopeFrame.FrameOffsetLo = uFrame.AddrFrame.Offset
        uScopeFrame.StackOffsetLo = uFrame.AddrStack.Offset
        Call SymSetContext(hProc, uScopeFrame, 0)
        uEnumCtx.FrameEbp = uFrame.AddrFrame.Offset
        uEnumCtx.Params = vbNullString
        Call SymEnumSymbols(hProc, 0, 0, AddressOf pvEnumSymCallback, VarPtr(uEnumCtx))
        If LenB(uEnumCtx.Params) <> 0 Then
            sFrame = sFrame & "  " & uEnumCtx.Params
        Else
            'sFrame = sFrame & "  [&H" & Hex$(uFrame.Params(0)) & ", &H" & Hex$(uFrame.Params(1)) & _
                ", &H" & Hex$(uFrame.Params(2)) & ", &H" & Hex$(uFrame.Params(3)) & "]"
        End If
        sOut = IIf(LenB(sOut) <> 0, sOut & vbCrLf, vbNullString) & sFrame
    Loop
QH:
    If hProc <> 0 Then
        Call SymCleanup(hProc)
    End If
    GetPdbCallstack = sOut
    Exit Function
EH:
    sOut = sOut & vbCrLf & "Critical error: " & Err.Description
    Resume QH
End Function

Private Function pvEnumSymCallback(uSym As SYMBOL_INFOW, ByVal lSymbolSize As Long, uEnumCtx As EnumContext) As Long
    Dim lReg            As Long
    Dim lOffset        As Long
    Dim lValAddr        As Long
    Dim lValue          As Long
    Dim sName          As String
    Dim sVal            As String

    On Error GoTo QH
    pvEnumSymCallback = 1
    If (uSym.Flags And SYMFLAG_PARAMETER) = 0 Then
        If (uSym.Flags And (SYMFLAG_REGREL Or SYMFLAG_FRAMEREL)) = 0 Then
            Exit Function
        End If
        If uSym.AddressLo <= 0 Then
            Exit Function
        End If
    End If
    sName = pvToString(VarPtr(uSym.NameBuf(0)))
    If LenB(sName) = 0 Then
        Exit Function
    End If
    If (uSym.Flags And SYMFLAG_VALUEPRESENT) <> 0 Then
        sVal = "&H" & Hex$(uSym.ValueLo)
    ElseIf (uSym.Flags And (SYMFLAG_REGREL Or SYMFLAG_FRAMEREL)) <> 0 Then
        lReg = uSym.Register
        lOffset = uSym.AddressLo
        If lReg = CV_REG_EBP Or lReg = CV_ALLREG_VFRAME Or (uSym.Flags And SYMFLAG_FRAMEREL) <> 0 Then
            lValAddr = uEnumCtx.FrameEbp + lOffset
            If IsBadReadPtr(lValAddr, 4) = 0 Then
                Call CopyMemory(lValue, ByVal lValAddr, 4)
                If Left$(sName, 1) = "s" And Mid$(sName, 2, 1) = UCase$(Mid$(sName, 2, 1)) Then
                    sVal = pvDumpString(lValue)
                Else
                    sVal = "&H" & Hex$(lValue)
                    If lValue <> 0 Then
                        If IsBadReadPtr(lValue, 4) = 0 Then
                            Call CopyMemory(lValue, ByVal lValue, 4)
                            sVal = sVal & "->&H" & Hex$(lValue)
                        End If
                    End If
                End If
            Else
                sVal = "<unreadable>"
            End If
        ElseIf lOffset < 0 Then
            sVal = "<" & pvRegName(lReg) & "-&H" & Hex$(-lOffset) & ">"
        Else
            sVal = "<" & pvRegName(lReg) & "+&H" & Hex$(lOffset) & ">"
        End If
    Else
        sVal = "<?>"
    End If
    uEnumCtx.Params = IIf(LenB(uEnumCtx.Params) <> 0, uEnumCtx.Params & ", ", vbNullString) & sName & "=" & sVal
QH:
End Function

Private Function pvModuleName(ByVal hProc As Long, ByVal lAddr As Long) As String
    Dim lBase          As Long
    Dim lLen            As Long
    Dim lPos            As Long
    Dim sPath          As String

    lBase = SymGetModuleBase(hProc, lAddr)
    If lBase = 0 Then
        Exit Function
    End If
    sPath = String$(MAX_PATH, 0)
    lLen = GetModuleFileName(lBase, StrPtr(sPath), MAX_PATH)
    If lLen = 0 Then
        Exit Function
    End If
    sPath = Left$(sPath, lLen)
    lPos = InStrRev(sPath, "\")
    If lPos > 0 Then
        sPath = Mid$(sPath, lPos + 1)
    End If
    pvModuleName = sPath
End Function

Private Function pvDumpString(ByVal lPtr As Long) As String
    Dim sResult        As String

    If pvTryDumpString(lPtr, sResult) Then
        pvDumpString = """" & Replace(sResult, """", """""") & """"
        Exit Function
    End If
    pvDumpString = "&H" & Hex$(lPtr)
    If lPtr <> 0 Then
        If IsBadReadPtr(lPtr, 4) = 0 Then
            Call CopyMemory(lPtr, ByVal lPtr, 4)
            If pvTryDumpString(lPtr, sResult) Then
                pvDumpString = pvDumpString & "->""" & Replace(sResult, """", """""") & """"
            End If
        End If
    End If
End Function

Private Function pvTryDumpString(ByVal lPtr As Long, sResult As String) As Boolean
    Dim lLen            As Long
    Dim nChar          As Integer

    If lPtr = 0 Then
        sResult = vbNullString
        pvTryDumpString = True
        Exit Function
    End If
    If IsBadReadPtr(lPtr - 4, 4) <> 0 Then
        Exit Function
    End If
    Call CopyMemory(lLen, ByVal lPtr - 4, 4)
    If lLen < 0 Or lLen > 2 * MAX_STR_DUMP Or (lLen And 1) <> 0 Then
        Exit Function
    End If
    If IsBadReadPtr(lPtr, lLen + 2) <> 0 Then
        Exit Function
    End If
    Call CopyMemory(nChar, ByVal lPtr + lLen, 2)
    If nChar <> 0 Then
        Exit Function
    End If
    sResult = pvToString(lPtr)
    '--- success
    pvTryDumpString = True
End Function

Private Function pvToString(ByVal lPtr As Long) As String
    Call SysReAllocString(VarPtr(pvToString), lPtr)
End Function

Private Function pvRegName(ByVal lReg As Long) As String
    Static vNames      As Variant

    If lReg = CV_ALLREG_VFRAME Then
        pvRegName = "VFRAME"
    ElseIf lReg >= 1 And lReg <= 30 Then
        If Not IsArray(vNames) Then
            vNames = Split("AL CL DL BL AH CH DH BH AX CX DX BX SP BP SI DI EAX ECX EDX EBX ESP EBP ESI EDI ES CS SS DS FS GS")
        End If
        pvRegName = vNames(lReg - 1)
    Else
        pvRegName = "reg" & lReg
    End If
End Function

---

cheers,
</wqw>