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

Question

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

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

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

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

---

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

标准模块：WinAPI

我使用new style of subclassing是因为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使用模块的this full version

用户格式：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，则在完成任何代码后，按钮按下都会排队执行，并按照预期破坏Userform，触发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循环提供了reset按钮的入口点），则会崩溃。

我不明白...

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

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

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

---

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