子类化 - zAddressOf

'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
' Note: used both in subclassing and hooking routines
Dim bSub As Byte 'Value we expect to find pointed at by a vTable method entry
Dim bVal As Byte
Dim nAddr As Long 'Address of the vTable
Dim i As Long 'Loop index
Dim J As Long 'Loop limit

RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4 'Get the address of the callback object's instance
If Not zProbe(nAddr + &H1C, i, bSub) Then 'Probe for a Class method
If Not zProbe(nAddr + &H6F8, i, bSub) Then 'Probe for a Form method
' \\LaVolpe - Added propertypage offset
If Not zProbe(nAddr + &H710, i, bSub) Then 'Probe for a PropertyPage method
If Not zProbe(nAddr + &H7A4, i, bSub) Then 'Probe for a UserControl method
Exit Function 'Bail...
End If
End If
End If
End If

i = i + 4 'Bump to the next entry
J = i + 1024 'Set a reasonable limit, scan 256 vTable entries
Do While i < J
RtlMoveMemory VarPtr(nAddr), i, 4 'Get the address stored in this vTable entry

If IsBadCodePtr(nAddr) Then 'Is the entry an invalid code address?
RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4 'Return the specified vTable entry address
Exit Do 'Bad method signature, quit loop
End If
RtlMoveMemory VarPtr(bVal), nAddr, 1 'Get the byte pointed to by the vTable entry
If bVal <> bSub Then 'If the byte doesn't match the expected value...
RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4 'Return the specified vTable entry address
Exit Do 'Bad method signature, quit loop
End If

i = i + 4 'Next vTable entry
Loop
End Function

'Probe at the specified start address for a method signature
Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
Dim bVal As Byte
Dim nAddr As Long
Dim nLimit As Long
Dim nEntry As Long

nAddr = nStart 'Start address
nLimit = nAddr + 32 'Probe eight entries
Do While nAddr < nLimit 'While we've not reached our probe depth
RtlMoveMemory VarPtr(nEntry), nAddr, 4 'Get the vTable entry

If nEntry <> 0 Then 'If not an implemented interface
RtlMoveMemory VarPtr(bVal), nEntry, 1 'Get the value pointed at by the vTable entry
If bVal = &H33 Or bVal = &HE9 Then 'Check for a native or pcode method signature
nMethod = nAddr 'Store the vTable entry
bSub = bVal 'Store the found method signature
zProbe = True 'Indicate success
Exit Do 'Return
End If
End If

nAddr = nAddr + 4 'Next vTable entry
Loop
End Function