为什么在子类化的过程中我不能`End`代码而不破坏所有内容？

Question

我已经在VBA中编写了一些代码来子类化用户表单，以便最终我可以截获WM_TIMER发送给它的消息。我这样做不是指定TIMERPROC，因为它允许我使用VBA自己的错误处理和调用方法来运行回调函数。我使用的是用户表单，而不是Application.hWnd因为：

1. 我不必过滤我的vs Excel /主机应用程序的消息
2. 太多的消息正在传递Application.hWnd，无法以慢速解释的语言（如VBA）对其进行子类化
3. 当代码执行中断（按“停止”按钮或遇到End语句）时，用户窗体将自行消失-断开所有仍在发送消息的计时器。
   • 使用应用程序窗口，或更糟糕的是，像以前一样创建自己的消息窗口，这意味着使用创建的计时器SetTimer继续触发我的消息窗口

一切正常，除了我发现偶而在我的代码启动并运行时，按下复位/停止按钮，一切都崩溃了。

我希望我的窗口可以取消分类并安全地销毁。

---

我创建了以下内容，以允许我将用户窗体作为子类（尚无计时器，问题仅通过子类化即可显现出来）：

标准模块： WinAPI

我使用了新的子类风格，因为MSDN告诉我这样做，以防万一我需要添加更多子类-但这不会有所作为。

Option Explicit

Public Enum WindowsMessage 'As Long - for intellisense
    WM_TIMER = &H113 'only care about this one
    '...
End Enum

Public Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" ( _
                        ByVal hWnd As LongPtr, _
                        ByVal uMsg As WindowsMessage, _
                        ByVal wParam As LongPtr, _
                        ByVal lParam As LongPtr) As LongPtr

Public Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" ( _
                        ByVal hWnd As LongPtr, _
                        ByVal pfnSubclass As LongPtr, _
                        ByVal uIdSubclass As LongPtr, _
                        Optional ByVal dwRefData As LongPtr) As Long

Public Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" ( _
                        ByVal hWnd As LongPtr, _
                        ByVal pfnSubclass As LongPtr, _
                        ByVal uIdSubclass As LongPtr) As Long

有关更多WinAPI函数以帮助调试的信息，例如SetTimer和Peek/或PostMessage使用该模块的完整版本

用户表格： ModelessMessageWindow

我已经showModal准备好了False，但是我从未.Show如此无关紧要

'@Folder("FirstLevelAPI")
Option Explicit

Private Type messageWindowData
    subClassIDs As New Dictionary '{proc:id}
End Type
Private this As messageWindowData

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef outHwnd As LongPtr) As Long
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef outHwnd As Long) As Long
#End If

#If VBA7 Then
    Public Property Get handle() As LongPtr
        IUnknown_GetWindow Me, handle
    End Property
#Else
    Public Property Get handle() As Long
        IUnknown_GetWindow Me, handle
    End Property
#End If

Public Function tryCreate(ByRef outWindow As ModelessMessageWindow, Optional ByVal windowProc As LongPtr = 0, Optional ByVal data As LongPtr) As Boolean
    With New ModelessMessageWindow
        .Init
        If windowProc = 0 Then
            tryCreate = True
        Else
            tryCreate = .tryAddSubclass(windowProc, data)
        End If
        Set outWindow = .Self
    End With
End Function

Public Property Get Self() As ModelessMessageWindow
    Set Self = Me
End Property

Public Sub Init()
    'Need to run this for window to be able to receive messages
    'Me.Show
    'Me.Hide
End Sub

Public Function tryAddSubclass(ByVal subclassProc As LongPtr, Optional ByVal data As LongPtr) As Boolean

    Dim instanceID As Long
    'Only let one instance of each subclassProc per windowHandle

    If this.subClassIDs.Exists(subclassProc) Then
        instanceID = this.subClassIDs(subclassProc)
    Else
        instanceID = this.subClassIDs.Count
        this.subClassIDs(subclassProc) = instanceID
    End If

    If WinAPI.SetWindowSubclass(handle, subclassProc, instanceID, data) Then
        tryAddSubclass = True
    End If
End Function

'@Description("Remove any registered subclasses - returns True if all removed successfully")
Public Function tryRemoveAllSubclasses() As Boolean

    Dim timerProc As Variant
    Dim result As Boolean
    result = True 'if no subclasses exist the we removed them nicely
    For Each timerProc In this.subClassIDs.Keys
        result = result And WinAPI.RemoveWindowSubclass(handle, timerProc, this.subClassIDs(timerProc)) <> 0
    Next timerProc
    this.subClassIDs.RemoveAll
    tryRemoveAllSubclasses = result
End Function

---

我发现问题是由一个DoEvents语句引起的，该语句允许按下复位按钮来中断代码执行（不执行DoEvents，则在任何代码执行完毕后，按钮按下都会排队，并且只是破坏了预期的用户窗体，从而触发了Windows干净地删除子类）。可以使用以下End语句模拟相同的问题行为：

标准模块： SubclassingTest

'@Folder("Tests.Experiments")
Option Explicit

Public Function subclassProc(ByVal hWnd As LongPtr, ByVal uMsg As WindowsMessage, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal uIdSubclass As LongPtr, ByVal dwRefData As LongPtr) As LongPtr
    Debug.Print "MSG #"; uMsg 'will this even print, or have we interrupted repainting the thread?
    subclassProc = WinAPI.DefSubclassProc(hWnd, uMsg, wParam, lParam)
End Function

Sub createWindow()
    'get window and subclass it
    Static messageWindow As ModelessMessageWindow 'so it hovers around in memory
    Debug.Print "Creating window"
    If Not ModelessMessageWindow.tryCreate(messageWindow, AddressOf subclassProc) Then
        Debug.Print "Couldn't get/subclass window"
        Exit Sub
    End If
End Sub

Sub nukeEverything()
    End
End Sub

运行后createWindow，尝试按复位按钮；它工作正常，没有崩溃，并且我得到了以下消息：

MSG # 799 'WM_APPCOMMAND +3 - after createWindow but before pressing the button
MSG # 528 'WM_PARENTNOTIFY  
MSG # 144 'WM_MYSTERY +5 - IDK what this is
MSG # 2   'WM_DESTROY
MSG # 130 'WM_NCDESTROY

但是，如果我改为运行nukeEverything（或者让DoEvents循环提供了“重置”按钮的入口点），则会崩溃。

我不明白...

...这就是为什么在执行中间结束（DoEvents允许按下重置按钮或通过End语句）与异步方法不同的原因。我已经检查过AddressOf，回调不受End*的影响：

Sub checkPointer() 'always prints the same
    Debug.Print "Address: "; VBA.CLngPtr(AddressOf subclassProc)
    End
End Sub

即崩溃不是我的SUBCLASSPROC函数指针变为无效的结果。End当我不对Windows进行子类化时，当然也不会使Excel崩溃。那么究竟是什么导致了崩溃？还是有更好的方法（我知道我可以使用TIMERPROCS达到非常相似的结果，但我很好奇理解为什么会发生此错误，所以不想诉诸于此）

---

* 在注释中建议，也许函数指针每次都被分配相同的地址，使其看起来仍然有效，但是实际上每次运行时都会被销毁End，这会导致崩溃（当Windows尝试调用SUBCLASSPROC）。但是我不认为这是真的。如果您创建一个设置了TIMERPROC回调的计时器，则按“重置”按钮或运行NukeEverything不会停止Windows继续运行该回调。回调函数在同步/异步状态丢失之间确实保持有效，因此我想我的SUBCLASSPROC也应该如此。