VBA: Обходной путь для эмуляции оператора AddressOf в модуле класса

Question

Мне нужно использовать ряд Windows API функций в классе, который я разрабатываю. Некоторые из этих функций требуют использования AddressOf, но согласно Документация Microsoft , его использование в модуле класса запрещено. Кто-нибудь знает функцию или какой-нибудь стандартный метод, который может эмулировать оператор AddressOf, или это вообще возможно?

Пример: я использую функцию SetTimer для вызова функции в определенное время. Вы могли бы сказать, что вы могли бы просто использовать Application.OnTime. Вы были бы правы в любое другое время, но в этом случае я не могу, потому что вызывающая функция, которая используется для создания экземпляра класса и вызова метода, - это UDF, вызываемая из рабочего листа, которая игнорирует OnTime вызовы. Я пытаюсь избежать неуклюжей реализации размещения публичной функции в стандартном модуле (который будет зависеть от экземпляра класса), где я мог бы использовать оператор AddressOf, хотя и безобразно.

Редактировать: Как уже упоминалось в комментариях, изначально я намеренно не раскрывал, что именно я пытался сделать, чтобы не слышать "ты не должен этого делать", смеется. У меня есть рабочий класс, который делает именно то, что я хочу, (возвращает массивы на лист, используя стандартный метод Ctrl+Shift+Enter), но я хотел попробовать и эмулировать Dynamic Array Functions, который в настоящее время проходит бета-тестирование Команда разработчиков Excel, которая не требует выбора диапазона и ввода массива с помощью Ctrl+Shift+Enter. Я знал, что если бы я спросил что-то вроде «как я могу вернуть массив в WorkSheet из UDF без Ctrl+Shift+Enter», все бы предоставили существующие ответы и / или позорили бы меня за то, как реализовать что-то, что противоречит тому, как работают функции Excel ( Я бы сделал то же самое с кем-то еще, ха).

Сказав это, у меня также есть еще одна версия моего класса, которая использует объект QueryTable для размещения данных на листе и работает так же, как Dynamic Array Functions. Я, вероятно, собираюсь опубликовать каждую реализацию на Code Review , чтобы увидеть, как я мог бы улучшить их / получить представление о том, какая реализация будет наиболее стабильной, т. Д.

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

Вы можете использовать некоторый язык ассемблера, чтобы нарушить ограничения vb, конечно, плюсы и минусы которых зависят от вас. Я просто носильщик. Есть функция 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

Параметр SinceCount: Какая это функция из верхней функции или атрибута модуля класса?

1. Когда искомая функция является публичной функцией, ее значением является число функций, вычисленных сверху, например, публичная функция WndProc, записанная в верхней части модуля класса, затем передайте 1, если она является вторая открытая функция или свойство, затем по очереди передайте 2 ... Обратите внимание, что при вычислении также должно быть вычислено публичное свойство.

2. Когда искомая функция является локальной функцией, то есть если это частная модифицированная функция, значением параметра является количество всех открытых функций + индекс этой закрытой функции. Также рассчитывается сверху, включая атрибуты.

К сожалению, я бы сказал, что мы не можем использовать его напрямую. Некоторые параметры будут добавлены в функцию после компиляции, например указатель vTable. Поэтому нам нужно построить небольшую функцию -> функцию класса.

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

Answer 2

Обычный способ решения проблемы модуля класса AddressOf в VB6 / VBA - это поместить реальный обратный вызов в обычный модуль и заставить его отправить вызов правильному получателю.

например. для подкласса можно найти получателя по hWnd. Например. для таймера, который не связан с окном, его можно найти по idEvent, который система сгенерирует для вас правильно, если вы передадите нули в SetTimer, как вы это сделали.

В стандартном модуле:

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

В классе с именем ITimer:

Option Explicit

Public Sub TimerProc(ByVal dwTime As Long)
End Sub

---

Идея состоит в том, что любой класс может затем реализовать ITimer и передать себя StartTimerForHandler. Например. в другом классе с именем 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

А потом еще где-нибудь:

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