Re: Emulate AddressOf operator

"Mark Yudkin" <myudkinATcompuserveDOTcom@xxxxxxxxxxxxxx> wrote in message
news:eB7M$$y8FHA.2152@xxxxxxxxxxxxxxxxxxxxxxx
> You can't. A class has a lifecycle and context that "prevents" usage of
> any of it methods as a callback routine (in other words, the question is
> semantic nonsense).

Actually that's not true. I've done timer callbacks, hook callbacks and
subclassing callbacks inside a class. I had a class once that did all of
these but can't find it at the moment. However I have got code to do a timer
callback in a class. To test it, create an exe project, add a class called
clsTimer and paste in the code below. Then paste the code below this code
into form1. This was originally designed for vb4 so had a late bound
callback instead of the event but I just added the event now. Probably the
SetRect code could be replaced with VarPtr as well.

Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal
nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) 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 Declare Function SetRectByt Lib "user32" Alias "SetRect" (lpRect As
Long, ByRef X1 As Byte, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As
Long) As Long
'Set Rect is redifined with the second parameter as Byte and ByRef. This way
SetRect is passed in the pointer
'to X1 and returns this pointer in lpRect

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 NewVal As Boolean)
If NewVal Then
If mlngTimerId = 0 Then
mlngTimerId = SetTimer(0&, 0&, mlngInterval,
VarPtrByt(mbytData(0)))
If mlngTimerId = 0 Then Err.Raise vbObjectError,
"clsTimer.Running", "Timer failed to start."
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) -
VarPtrByt(mbytData(10)), 4 'call TimerProc

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 VarPtrByt(ByRef bytRef As Byte) As Long
'To get a pointer to a variable, an API call that returns a value it is
given is required
'It is also a big bonus if the API call doesn't actually do anything :)
'The SetRect API does this

Dim lngX(3) As Long 'Replacement for RECT structure
SetRectByt lngX(0), bytRef, 0, 0, 0
VarPtrByt = lngX(0)
End Function

Private Function GetVTableAddress(objRef As Object, Offset As Long) As Long
Dim lngX As Long
CopyMemory lngX, objRef, 4 'lngx=ObjPtr(Me)
CopyMemory lngX, ByVal lngX, 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


-------------------------------------------------------
form1code:

Option Explicit

Private WithEvents T As clsTimer

Private Sub Form_Load()
Set T = New clsTimer
T.Interval = 1000
T.Running = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
T.Running = False
End Sub

Private Sub T_Timer(ByVal dwTime As Long)
Me.Caption = Me.Caption & "."
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: 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)
  • Re: set fontsize with variable
    ... Public Function MsgBoxDLL(Optional strPrompt As String, ... Private m_Prompt As String ... Public Property Let Prompt ... Private Sub cmdButton1_Click ...
    (microsoft.public.vb.general.discussion)