VBA: Workaround To Emulate AddressOf Operator In A Class Module
You can use some assembly language to break limitations of vb, of course, the pros and cons of which are up to you. I'm just a porter. There's a function GetClassProcAddress：
Private Function GetClassProcAddress(ByVal SinceCount As Long) As Long
Dim i As Long, jmpAddress As Long
CopyMemory i, ByVal ObjPtr(Me), 4 ' get vtable
CopyMemory i, ByVal i + (SinceCount - 1) * 4 + &H1C, 4 '
CopyMemory jmpAddress, ByVal i + 1, 4 ' The function address obtained is actually a table, a jump table
GetClassProcAddress = i + jmpAddress + 5 ' Calculate jump relative offset to get the actual address
End Function
Parameter SinceCount: From the top function or attribute of a class module, which function is it?
When the function being searched is a public function, its value is the number of functions calculated from the top, such as a public function WndProc written at the top of the class module, then pass 1 if it is the second public function or property, then pass 2 in turn... Note that when calculating, the public property should also be calculated.
When the function being searched is a local function, that is to say, if it is a Private modified function, the parameter value is the number of all public functions + the index of this private function. Also calculated from the top, including attributes as well.
Unfortunately, I would say that we could not use it directly. Some parameters will be added to the function after compiling, like vTable pointer. So we need to construct a small function -> class function.
Private Function GetClassProcAddr(obj As Object, ByVal Index As Long, _
Optional ByVal ParamCount As Long = 4, Optional ByVal HasReturnValue As Boolean) As Long
Static lReturn As Long, pReturn As Long
Static AsmCode(50) As Byte
Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long
pThis = ObjPtr(obj)
CopyMemory pVtbl, ByVal pThis, 4
CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4
pReturn = VarPtr(lReturn)
For i = 0 To UBound(AsmCode) 'fill nop
AsmCode(i) = &H90
Next
AsmCode(0) = &H55 'push ebp
AsmCode(1) = &H8B: AsmCode(2) = &HEC 'mov ebp,esp
AsmCode(3) = &H53 'push ebx
AsmCode(4) = &H56 'push esi
AsmCode(5) = &H57 'push edi
If HasReturnValue Then
AsmCode(6) = &HB8 'mov offset lReturn
CopyMemory AsmCode(7), pReturn, 4
AsmCode(11) = &H50 'push eax
End If
For i = 0 To ParamCount - 1 'push dword ptr[ebp+xx]
AsmCode(12 + i * 3) = &HFF
AsmCode(13 + i * 3) = &H75
AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
Next
i = i * 3 + 12
AsmCode(i) = &HB9 'mov ecx,this
CopyMemory AsmCode(i + 1), pThis, 4
AsmCode(i + 5) = &H51 'push ecx
AsmCode(i + 6) = &HE8 'call relative address
CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4
If HasReturnValue Then
AsmCode(i + 11) = &HB8 'mov eax,offset lReturn
CopyMemory AsmCode(i + 12), pReturn, 4
AsmCode(i + 16) = &H8B 'mov eax,dword ptr[eax]
AsmCode(i + 17) = &H0
End If
AsmCode(i + 18) = &H5F 'pop edi
AsmCode(i + 19) = &H5E 'pop esi
AsmCode(i + 20) = &H5B 'pop ebx
AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5 'mov esp,ebp
AsmCode(i + 23) = &H5D 'pop ebp
AsmCode(i + 24) = &HC3 'ret
GetClassProcAddr = VarPtr(AsmCode(0))
End Function
Code Reference from: https://blog.csdn.net/lyserver/article/details/4224676
The usual way to solve the class module AddressOf problem in VB6/VBA is to put the actual callback in a regular module and have it dispatch the call to the correct recipient.
E.g. for subclassing, the recipient can be looked up by hWnd. E.g. for a timer that is not associated with a window, it can be looked up by idEvent which the system will correctly generate for you if you pass zeroes to SetTimer like you did.
In a standard module:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal HWnd As LongPtr, byval uIDEvent As LongPtr) As Long
#Else
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 uIDEvent As Long) As Long
#End If
Private mLookupByTimerId As Collection
Private mLookupByHandler As Collection
Public Sub StartTimerForHandler(ByVal Handler As ITimer, ByVal DurationInMs As Long)
If Handler Is Nothing Then Err.Raise 5, , "Handler must be provided"
If mLookupByTimerId Is Nothing Then Set mLookupByTimerId = New Collection
If mLookupByHandler Is Nothing Then Set mLookupByHandler = New Collection
#If VBA7 Then
Dim h As LongPtr
#Else
Dim h As Long
#End If
h = SetTimer(0, 0, DurationInMs, AddressOf TimerProc)
If h = 0 Then
Err.Raise 5, , "An error creating the timer"
Else
mLookupByTimerId.Add Handler, Str(h)
mLookupByHandler.Add h, Str(ObjPtr(Handler))
End If
End Sub
Public Sub KillTimerForHandler(ByVal Handler As ITimer)
#If VBA7 Then
Dim h As LongPtr
#Else
Dim h As Long
#End If
Dim key As String
key = Str(ObjPtr(Handler))
h = mLookupByHandler(key)
mLookupByHandler.Remove key
mLookupByTimerId.Remove Str(h)
KillTimer 0, h
End Sub
#If VBA7 Then
Private Sub TimerProc(ByVal HWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)
#Else
Private Sub TimerProc(ByVal HWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
#End If
Dim h As ITimer
Set h = mLookupByTimerId(Str(idEvent))
h.TimerProc dwTime
End Sub
In a class named ITimer:
Option Explicit
Public Sub TimerProc(ByVal dwTime As Long)
End Sub
The idea is that any class can then implement ITimer and pass itself to StartTimerForHandler. E.g. in a different class named DebugPrinter:
Option Explicit
Implements ITimer
Public Sub StartNagging()
Module1.StartTimerForHandler Me, 1000
End Sub
Public Sub StopNagging()
Module1.KillTimerForHandler Me
End Sub
Private Sub ITimer_TimerProc(ByVal dwTime As Long)
Debug.Print dwTime
End Sub
And then somewhere else:
Option Explicit
Private Naggers(1 To 5) As DebugPrinter
Sub StartMassiveNagging()
Dim i As Long
For i = LBound(Naggers) To UBound(Naggers)
Set Naggers(i) = New DebugPrinter
Naggers(i).StartNagging
Next
End Sub