VBA：在类模块中模拟AddressOf运算符的解决方法

Question

我需要Windows API在正在开发的类中使用许多功能。其中一些功能需要使用AddressOf，但根据Microsoft文档，禁止在类模块中使用。有人知道可以模仿AddressOf操作员的功能或某些标准方法吗，或者甚至可能吗？

示例：我正在使用该SetTimer函数在特定时间调用一个函数。您可能会说很好，您可以使用Application.OnTime。您在任何其他时间都是对的，但在这种情况下我做不到，因为用于实例化类和调用方法的调用函数是UDF从工作表中OnTime调用的，它忽略了调用。我试图避免在标准模块（该类依赖于该类的实例）中放置公共函数的笨拙实现AddressOf，尽管我可以用丑陋的方式使用它。

编辑： 如评论中所述，起初，我有意未完全透露自己在试图避免听到的“我不应该那样做”的内容，大声笑。我有一个工作类别，可以完全满足我的要求（使用的标准方法将数组返回到工作表Ctrl+Shift+Enter），但是我想尝试模拟Dynamic Array Functions目前由Excel开发团队进行Beta测试的，不需要选择范围并通过输入数组Ctrl+Shift+Enter。我知道如果我问类似“如何不从UDF将数组从UDF返回到WorkSheet之类的问题Ctrl+Shift+Enter”，每个人都会提供现有答案，并且/或者让我感到羞耻，因为我想问如何实现与excel函数方式相矛盾的东西（我会这样做别人也一样，哈）。

这样说，我还有一个类的另一个版本，该版本使用该QueryTable对象将数据放置在工作表中，并且工作原理与相似Dynamic Array Functions。我可能会在代码审查中发布每个实现，以查看如何改进它们/获得一些最稳定的实现的见解。

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

代码参考来自：https : //blog.csdn.net/lyserver/article/details/4224676

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