VBA: Workaround To Emulate AddressOf Operator In A Class Module

Question

I need make use of several Windows API functions in a Class that I am developing, for a hobby project. Several of these functions require the use of the AddressOf Operator, but as per Microsoft Documentation, its use in a Class Module is prohibited.

Does anyone know of a function or some standard method that can emulate the the AddressOf Operator, or is that even possible?

Background
The app centers around functions that are called from the worksheet, which are then used to instantiate a class and call a method using the SetTimer WinAPI function.

You might say: "Well, you could just use Application.OnTime", and you would be right, IF the function was NOT called from the worksheet. For good reason, Excel's calculation engine explicitly ignores calls to Application.OnTime, (if the caller be the worksheet); however, SetTimer happens to work regardless.

I want to avoid the clunky implementation of placing a public function in a standard module, (which would be dependent on an instance of the class), where I WOULD be able to use the AddressOf Operator, albeit in an ugly, un-encapsulated way.

Edit: As mentioned in the comments, initially, I intentionally did not disclose exactly what I was trying to do to avoid hearing "you shouldn't do that", lol. I have a working class that does exactly what I want it to do, (i.e. return arrays to the worksheet using the standard method of Ctrl+Shift+Enter), but I wanted to try and emulate the Dynamic Array Functions that are currently being beta tested by the Excel dev team, which do not require you select the range and enter an array via Ctrl+Shift+Enter. I knew if I asked something like "how can I return an array to the WorkSheet from a UDF without Ctrl+Shift+Enter", everyone would provide existing answers and/or shame me, (I would do the same if someone else asked, lol), for asking how to implement something that contradicts the way Excel's calculation engine was intended to function.

Saying that, I also have yet another version of my class that uses the QueryTable object to place data in the sheet and works much like the Dynamic Array Functions. I am probably going to post each implementation on Code Review to see how I could improve them/gain some insight to which would be the most stable implementation, etc.

Private Declare Function SetTimer Lib "user32" _
        (ByVal HWnd As Long, ByVal nIDEvent As Long, 
         ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Public Function Method1(varValsIn As Variant) As Variant
  
  Dim lngWindowsTimerID As Long
        
        'doing some stuff
        
        'call API function after doing some stuff
        lngWindowsTimerID = SetTimer(0&, 0&, 1, AddressOf DoStuff)

End Sub 

Private Sub DoStuff
    'Stuff to do
End Sub

Answer 1

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?

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

Answer 2

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