Context
I've written some code in VBA to subclass a userform so that ultimately I can intercept WM_TIMER messages being dispatched to it. I'm doing this instead of specifying a TIMERPROC, as it allows me to use VBA's own error handling and calling methods to run callback functions. I'm using a userform rather than Application.hWnd because:
- I don't have to filter for my vs Excel/the host application's messages.
- There are far too many messages going through
Application.hWndto be able to subclass it in a slow interpreted language like VBA. - When code execution is interrupted (pressing the stop button, or upon encountering an
Endstatement), the userform vanishes all by itself - disconnecting any timers still sending messages.- Using the Application window, or worse, creating my own message window as I had previously been doing means the timers created with
SetTimercontinue to trigger my message window
- Using the Application window, or worse, creating my own message window as I had previously been doing means the timers created with
It's all working fine, except I've found that occasionally when my code is up and running, and I press the reset/stop button, everything crashes.
I'd prefer for my window to be un-subclassed and destroyed safely.
I created the following to allow me to subclass a userform (no timers yet, the problem manifests itself just by subclassing):
Standard module: WinAPI
I'm using the new style of subclassing because MSDN told me to, and in case I need to add more subclasses - shouldn't make a difference though.
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
For more WinAPI functions to help with debugging, like SetTimer and Peek/PostMessage use this full version of the module
Userform: ModelessMessageWindow
I've got showModal set to False, but I never .Show so probably irrelevant
'@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
I've discovered that the problem is caused by a DoEvents statement, which allows a reset-button press to interrupt code execution (without DoEvents, the button press is queued after any code has finished executing, and just destroys the Userform as expected, triggering Windows to remove the subclasses cleanly). The same problematic behaviour can be simulated with the End statement:
Standard module: 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
After running createWindow, try pressing the reset button; it works fine and nothing crashes, and I get these messages printed:
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
However if I instead run nukeEverything (or have a DoEvents loop providing an entry point for the reset button), I get a crash.
What I don't understand...
...is why ending stuff mid-execution (either with DoEvents allowing a reset button press through, or via the End statement) is different from the asynchronous approach. I've checked and the AddressOf the callback isn't affected by End*:
Sub checkPointer() 'always prints the same
Debug.Print "Address: "; VBA.CLngPtr(AddressOf subclassProc)
End
End Sub
i.e. the crash isn't the result of my SUBCLASSPROC function pointer becoming invalid. And of course End doesn't crash Excel when I'm not subclassing windows. So what exactly is causing the crash? Or is there a better approach (I know I can achieve very similar results using TIMERPROCS, but I'm curious to understand why this error is happening and so don't want to resort to those)
*It has been suggested in the comments that perhaps the function pointer just gets assigned the same address every time, making it appear to remain valid, but it is indeed being destroyed each time I run End and that's causing the crash (when Windows tries to invoke the SUBCLASSPROC). However I don't think this is true; if you create a timer with a TIMERPROC callback set, then pressing the reset button or running NukeEverything does not stop Windows continuing to run the callback. The callback function does remain valid between synchronous/asynchronous state losses, so I imagine my SUBCLASSPROC should too.
