Re: Emulate AddressOf operator

Tech-Archive recommends: Fix windows errors by optimizing your registry

Updated version:

Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal
nIDEvent As Long, ByVal uElapse As Long, ByRef lpTimerFunc As Byte) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal
nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private mlngTimerId As Long
Private mlngInterval As Long
Private mbytData(12) As Byte

Public Event Timer(ByVal dwTime As Long)

Public Sub TimerProc()
RaiseEvent Timer(GetTickCount)
End Sub

Public Property Let Interval(ByVal NewVal As Long)
mlngInterval = NewVal
If Running Then
Running = False
Running = True
End If
End Property
Public Property Get Interval() As Long
Interval = mlngInterval
End Property

Public Property Let Running(ByVal RHS As Boolean)
If RHS Then
If mlngTimerId = 0 Then
mlngTimerId = SetTimer(0&, 0&, mlngInterval, mbytData(0))
If mlngTimerId = 0 Then Err.Raise vbObjectError,
"clsTimer.Running", "Failed to start timer."
End If
Else
If Not mlngTimerId = 0 Then
If KillTimer(0&, mlngTimerId) = 0 Then Err.Raise vbObjectError +
1, "clsTimer.Running", "Timer failed to stop."
mlngTimerId = 0
End If
End If
End Property
Public Property Get Running() As Boolean
Running = mlngTimerId <> 0
End Property

Private Sub Class_Initialize()
Dim lngX As Long

CopyMemory lngX, Me, 4 'lngX=ObjPtr(me)

mbytData(0) = &H68
CopyMemory mbytData(1), lngX, 4 'push this (me) on stack

mbytData(5) = &HE8
CopyMemory mbytData(6), GetVTableAddress(Me, 7) - VarPtr(mbytData(10)),
4 'call TimerProc
'value of 7 is used because TimerProc is actually the 8th function in
the VTable
'after QueryInterface, AddRef, Release, GetTypeInfoCount, GetTypeInfo,
GetIDsOfNames, Invoke

mbytData(10) = &HC2
mbytData(11) = &H10
mbytData(12) = &H0 'ret 10 --- return from
callback, removing 4 parameters from stack

'Dump from C++
'68 88 D8 17 00 push 17D888h 'push This
(me) on stack
'E8 4B B1 FD FF call 0018201B 'Call Timer
Proc
'C2 10 00 ret 10h 'Return

'Instead of the callback going directly into TimerProc, the callback
goes into the
'byte array. This byte array contains code to call the TimerProc. As the
TimerProc
'has no parameters and no return value (ie is a sub), no parameters need
to be
'passed to it except for 'This'. The TimerProc really looks like this:

'Public Function TimerProc(ByVal This As Long) As Long
End Sub

Private Function GetVTableAddress(ByVal objRef As Object, ByVal Offset As
Long) As Long
Dim lngX As Long
CopyMemory lngX, ByVal ObjPtr(objRef), 4 'Get pointer to VTable
CopyMemory GetVTableAddress, ByVal lngX + Offset * 4, 4 'Get function
pointer
End Function

Private Sub Class_Terminate()
Running = False 'Stop timer if it is running
End Sub





.

Relevant Pages

  • Re: DC another Problem
    ... > Private PointsDraw As ClassPoints ... > Private Sub Command1_Click ... > Dim p As Classpoint ... > Public Property Let X ...
    (microsoft.public.vb.winapi.graphics)
  • Re: DC another Problem
    ... >>Private PointsDraw As ClassPoints ... >>End Sub ... >>Dim p As Classpoint ... >>Public Property Let X ...
    (microsoft.public.vb.winapi.graphics)
  • RE: Alpha search to load a list box
    ... to load a list box with clients starting with the letter that is selected. ... Private Sub LblAlpha_MouseDown(Button As Integer, Shift As Integer, X As ... Private Declare Function apiDeleteObject Lib "gdi32" _ ...
    (microsoft.public.access.formscoding)
  • Re: Mute volume in vb.net program
    ... Private CurrentVolRight As Long ... Public Property Let CurrentVolume ... Public Sub IncreaseVolume() ... ' Note that the waveid is 0 indicating the first wave output device. ...
    (microsoft.public.dotnet.languages.vb)
  • Re: Get return from form in ActiveX dll
    ... Sub Test() ... Private Sub MB_evtButton(strCaption As String) ... Public Property Set ExcelApp ...
    (microsoft.public.vb.general.discussion)