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

mdCallStack.bas

'=== 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