我已经在VBA中编写了一些代码来子类化用户表单,以便最终我可以截获发送给它的WM_TIMER
消息。我这样做不是指定TIMERPROC,因为它允许我使用VBA自己的错误处理和调用方法来运行回调函数。我使用的是用户表单,而不是Application.hWnd
,因为:
Application.hWnd
的消息太多,无法以诸如VBA这样的慢速解释语言对其进行子类化End
语句)时,用户窗体本身全部消失-断开所有仍在发送消息的计时器。
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也应该如此。