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?

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

Tags:

Winapi

Excel

Vba