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 addressEnd Function

Parameter SinceCount: From the top function or attribute of a class module, which function is it?

1. 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.

2. 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 ThenPrivate Declare PtrSafe Function SetTimer Lib "user32" _  (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, _   ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtrPrivate Declare PtrSafe Function KillTimer Lib "user32" _  (ByVal HWnd As LongPtr, byval uIDEvent As LongPtr) As Long#ElsePrivate Declare Function SetTimer Lib "user32" _  (ByVal HWnd As Long, ByVal nIDEvent As Long, _   ByVal uElapse As Long, ByVal lpTimerFunc As Long) As LongPrivate Declare Function KillTimer Lib "user32" _  (ByVal HWnd As Long, ByVal uIDEvent As Long) As Long#End IfPrivate mLookupByTimerId As CollectionPrivate mLookupByHandler As CollectionPublic 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 IfEnd SubPublic 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, hEnd Sub#If VBA7 ThenPrivate Sub TimerProc(ByVal HWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long)#ElsePrivate 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 dwTimeEnd Sub

In a class named ITimer:

Option ExplicitPublic 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 ExplicitImplements ITimerPublic Sub StartNagging()  Module1.StartTimerForHandler Me, 1000End SubPublic Sub StopNagging()  Module1.KillTimerForHandler MeEnd SubPrivate Sub ITimer_TimerProc(ByVal dwTime As Long)  Debug.Print dwTimeEnd Sub

And then somewhere else:

Option ExplicitPrivate Naggers(1 To 5) As DebugPrinterSub StartMassiveNagging()  Dim i As Long  For i = LBound(Naggers) To UBound(Naggers)    Set Naggers(i) = New DebugPrinter    Naggers(i).StartNagging  NextEnd Sub