-
Jun 10th, 2010, 03:51 PM
#1
Advanced procedure hacking
Note: most of these features can be simply replicated with API calls that are about equal in speed. TLB files can perfectly replicate these features and be faster too. These may be interesting if you want to do advanced optimization or if you want to work with string arrays in a more powerful manner.
As such these aren't very useful, but provide some nice insight into internal data structures in VB6. I probably revise this post at a later date with more information.
Feel free to ask questions.
Code:
' Advanced.bas
Option Explicit
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Ptr As Long, Value As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long
Public Function InIDE(Optional IDE) As Boolean
If IsMissing(IDE) Then Debug.Assert Not InIDE(InIDE) Else IDE = True
End Function
Public Property Get Procedure(ByVal AddressOfDest As Long) As Long
Procedure = AddressOfDest
End Property
Public Property Let Procedure(ByVal AddressOfDest As Long, ByVal AddressOfSrc As Long)
Dim JMP As Currency, PID As Long
' get process handle
PID = OpenProcess(&H1F0FFF, 0&, GetCurrentProcessId)
If PID Then
If InIDE Then
' get correct pointers to procedures in IDE
GetMem4 AddressOfDest + &H16&, AddressOfDest
GetMem4 AddressOfSrc + &H16&, AddressOfSrc
End If
Debug.Assert App.hInstance
' ASM JMP (0xE9) followed by bytes to jump in memory
JMP = (&HE9& * 0.0001@) + (AddressOfSrc - AddressOfDest - 5@) * 0.0256@
' write the JMP over the destination procedure
WriteProcessMemory PID, ByVal AddressOfDest, JMP, 5
' close process handle
CloseHandle PID
End If
End Property
Code:
' Cast.bas
Option Explicit
Public Sub CurAsLong(ByVal Value As Currency, Low As Long, High As Long)
Procedure(AddressOf Cast.CurAsLong) = Procedure(AddressOf Cast.z_CurAsLong)
Cast.CurAsLong Value, Low, High
End Sub
Public Function IntAsLong(ByVal Low As Integer, ByVal High As Integer) As Long
Procedure(AddressOf Cast.IntAsLong) = Procedure(AddressOf Cast.z_IntAsLong)
IntAsLong = Cast.IntAsLong(Low, High)
End Function
Public Function LngAsCurrency(ByVal Low As Long, ByVal High As Long) As Currency
Procedure(AddressOf Cast.LngAsCurrency) = Procedure(AddressOf Cast.z_LngAsCurrency)
LngAsCurrency = Cast.LngAsCurrency(Low, High)
End Function
Public Sub LngAsInteger(ByVal Value As Long, Low As Integer, High As Integer)
Procedure(AddressOf Cast.LngAsInteger) = Procedure(AddressOf Cast.z_LngAsInteger)
Cast.LngAsInteger Value, Low, High
End Sub
Public Function LngAsSingle(ByVal Value As Long) As Single
Procedure(AddressOf Cast.LngAsSingle) = Procedure(AddressOf Cast.z_LngAsSingle)
LngAsSingle = Cast.LngAsSingle(Value)
End Function
Public Function SngAsLong(ByVal Value As Single) As Long
Procedure(AddressOf Cast.SngAsLong) = Procedure(AddressOf Cast.z_SngAsLong)
SngAsLong = Cast.SngAsLong(Value)
End Function
Public Sub z_CurAsLong(ByVal CurLow As Long, ByVal CurHigh As Long, Low As Long, High As Long)
Low = CurLow
High = CurHigh
End Sub
Public Function z_IntAsLong(ByVal Value As Long) As Long
z_IntAsLong = Value
End Function
Public Function z_LngAsCurrency(ByVal Value As Currency) As Currency
z_LngAsCurrency = Value
End Function
Public Sub z_LngAsInteger(ByVal CurLow As Integer, ByVal CurHigh As Integer, Low As Integer, High As Integer)
Low = CurLow
High = CurHigh
End Sub
Public Function z_LngAsSingle(ByVal Value As Single) As Single
z_LngAsSingle = Value
End Function
Public Function z_SngAsLong(ByVal Value As Long) As Long
z_SngAsLong = Value
End Function
Code:
' Pointer.bas
Option Explicit
Public Function BytArrPtr(Arr() As Byte) As Long
Procedure(AddressOf Pointer.BytArrPtr) = Procedure(AddressOf Pointer.z_ArrPtr)
BytArrPtr = Pointer.BytArrPtr(Arr)
End Function
Public Function GetLong(ByVal Ptr As Long) As Long
Procedure(AddressOf Pointer.GetLong) = Procedure(AddressOf Pointer.z_GetLong)
GetLong = Pointer.GetLong(Ptr)
End Function
Public Function IntArrPtr(Arr() As Integer) As Long
Procedure(AddressOf Pointer.IntArrPtr) = Procedure(AddressOf Pointer.z_ArrPtr)
IntArrPtr = Pointer.IntArrPtr(Arr)
End Function
Public Sub PutCurrency(ByVal Ptr As Long, ByVal Value As Currency)
Procedure(AddressOf Pointer.PutCurrency) = Procedure(AddressOf z_PutCurrency)
Pointer.PutCurrency Ptr, Value
End Sub
Public Sub PutLong(ByVal Ptr As Long, ByVal Value As Long)
Procedure(AddressOf Pointer.PutLong) = Procedure(AddressOf Pointer.z_PutLong)
Pointer.PutLong Ptr, Value
End Sub
Public Function StrArrPtr(Arr() As String) As Long
Procedure(AddressOf Pointer.StrArrPtr) = Procedure(AddressOf Pointer.z_ArrPtr)
StrArrPtr = Pointer.StrArrPtr(Arr)
End Function
Public Function z_ArrPtr(ByVal Value As Long) As Long
z_ArrPtr = Value
End Function
Public Function z_GetLong(Ptr As Long) As Long
z_GetLong = Ptr
End Function
Public Sub z_PutCurrency(Ptr As Currency, ByVal Value As Currency)
Ptr = Value
End Sub
Public Sub z_PutLong(Ptr As Long, ByVal Value As Long)
Ptr = Value
End Sub
Code:
' SafeArray.bas
Option Explicit
Public Function BytArrAsInteger(Arr() As Byte) As Integer()
Dim Ptr As Long, UB As Long
Ptr = Not Not Arr
Debug.Assert App.hInstance
If Ptr Then
UB = UBound(Arr)
If UB And 1 Then
PutLong BytArrPtr(Arr), 0
If GetLong(Ptr) And &H800000 Then PutLong Ptr - 4, vbInteger
PutLong Ptr + 4, 2
PutLong Ptr + 16, (UB + 1) \ 2
PutLong IntArrPtr(BytArrAsInteger), Ptr
End If
End If
End Function
Public Function IntArrAsByte(Arr() As Integer) As Byte()
Dim Ptr As Long, UB As Long
Ptr = Not Not Arr
Debug.Assert App.hInstance
If Ptr Then
UB = UBound(Arr)
PutLong IntArrPtr(Arr), 0
If GetLong(Ptr) And &H800000 Then PutLong Ptr - 4, vbByte
PutLong Ptr + 4, 1
PutLong Ptr + 16, (UB + 1) * 2
PutLong BytArrPtr(IntArrAsByte), Ptr
End If
End Function
Public Function NewByteArray() As Byte()
Dim H() As Long ' safe array header for an empty byte array
ReDim H(0 To 6): H(0) = vbByte: H(1) = &H800001: H(2) = 1
' H(1) becomes ArrPtr; H(0) is a negative item telling array datatype
PutLong Pointer.BytArrPtr(NewByteArray), VarPtr(H(1))
' remove items from H array
PutCurrency (Not Not H) + 12, 0
End Function
Public Function NewStringArray() As String()
Dim H() As Long ' safe array header for an empty string array
ReDim H(0 To 6): H(0) = vbString: H(1) = &H1800001: H(2) = 4
' H(1) becomes ArrPtr; H(0) is a negative item telling array datatype
PutLong Pointer.StrArrPtr(NewStringArray), VarPtr(H(1))
' remove items from H array
PutCurrency (Not Not H) + 12, 0
End Function
Last edited by Merri; Jun 12th, 2010 at 04:05 AM.
-
Jun 10th, 2010, 03:52 PM
#2
Re: Advanced procedure hacking
Reserved for possible future code or first post running out of space.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|