- Код: Выделить всё
' //
' // Debug redirect
' // by The trick
' //
Option Explicit
Private Enum PTR
[_]
End Enum
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleW" ( _
ByVal lpModuleName As PTR) As PTR
Private Declare Sub GetMem4 Lib "msvbvm60" ( _
ByRef pAddr As Any, _
ByRef pDst As Any)
Private Declare Sub GetMemPtr Lib "msvbvm60" _
Alias "GetMem4" ( _
ByRef pAddr As Any, _
ByRef pDst As Any)
Private Declare Sub GetMem8 Lib "msvbvm60" ( _
ByRef pAddr As Any, _
ByRef pDst As Any)
Private Declare Sub PutMemPtr Lib "msvbvm60" _
Alias "PutMem4" ( _
ByRef pDst As Any, _
ByVal pVal As PTR)
Private Function ReplaceDebugObject( _
ByVal pObj As PTR) As PTR
Static s_pCurObject As PTR
Dim hVBA As PTR
Dim pNTHdr As PTR
Dim pStart As PTR
Dim pEnd As PTR
Dim cSign As Currency
Dim lLength As Long
Dim lOldProtect As Long
If s_pCurObject = 0 Then
hVBA = GetModuleHandle(StrPtr("vba6"))
If hVBA = 0 Then Exit Function
GetMem4 ByVal hVBA + &H3C, pNTHdr
pNTHdr = pNTHdr + hVBA
GetMem4 ByVal pNTHdr + &H12C, pStart
pStart = pStart + hVBA
GetMem4 ByVal pNTHdr + &H128, lLength
pEnd = pStart + lLength - 8
Do While pStart <= pEnd
GetMem8 ByVal pStart, cSign
If cSign = 511398171365990.4051@ Then
GetMemPtr ByVal pStart + &H11, pStart
GetMemPtr ByVal pStart + &H44, pStart
GetMemPtr ByVal pStart + &H1, s_pCurObject
Exit Do
End If
pStart = pStart + 1
Loop
End If
If s_pCurObject = 0 Then
Err.Raise 51
End If
GetMemPtr ByVal s_pCurObject, ReplaceDebugObject
PutMemPtr ByVal s_pCurObject, pObj
End Function
Private Sub Form_Load()
Dim pOriginal As PTR
Me.AutoRedraw = True
pOriginal = ReplaceDebugObject(ObjPtr(Me))
Debug.Print "test"
Debug.Print "Hello", "world", Spc(10); "1234"; Tab(3); "vb6"
ReplaceDebugObject pOriginal
End Sub
Вместо ObjPtr(Me) можно передавать любой объект поддерживающий интерфейс IVBAPrint.