为什么我不能在不破坏所有内容的情况下在子类化时“结束”代码？

问：

上下文

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

1. 我不必过滤我的 vs Excel/主机应用程序的消息。
2. 有太多的消息正在传递，无法用像 VBA 这样的慢速解释语言对其进行子类化。Application.hWnd
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

我已经准备好了，但我从来都不是无关紧要的showModalFalse.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

我发现这个问题是由一个语句引起的，该语句允许按下重置按钮来中断代码执行（如果没有，按钮按下在任何代码完成执行后都会排队，并且只是按预期销毁用户窗体，触发 Windows 干净地删除子类）。同样的问题行为可以用以下语句来模拟：DoEventsDoEventsEnd

标准模块：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

但是，如果我改为运行（或有一个循环为重置按钮提供入口点），我就会崩溃。nukeEverythingDoEvents

我不明白的...

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

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

即崩溃不是我的 SUBCLASSPROC 函数指针无效的结果。当然，当我不对窗口进行子类化时，不会使 Excel 崩溃。那么究竟是什么导致了崩溃呢？或者有没有更好的方法（我知道我可以使用 TIMERPROCS 获得非常相似的结果，但我很好奇为什么会发生这个错误，所以不想求助于这些）End

*评论中有人建议，也许函数指针每次都会被分配相同的地址，使其看起来仍然有效，但每次我运行时它确实被销毁，这导致了崩溃（当 Windows 尝试调用 SUBCLASSPROC 时）。但是，我不认为这是真的;如果创建设置了 TIMERPROC 回调的计时器，则按下重置按钮或运行不会阻止 Windows 继续运行回调。回调函数在同步/异步状态丢失之间仍然有效，所以我想我的 SUBCLASSPROC 也应该有效。EndNukeEverything