This project continues the idea from this post (basically using an ActiveX DLL for subclassing while developing in IDE and switching to regular subclassing in the final executable based on a conditional compilation argument aptly named "bInIDE".
It turns out that all it takes to make the IDE completely crash-proof is to replace the implementation of the "ISubclass" interface with regular run-of-the-mill VB6 events. Now you can safely debug your code, click "Stop" or "End" and everything just works the same as it would with a VB6 native event (like "Form_Click" for example). It also provides a couple of advantages over regular events:
- You can use the additional "dwRefData" parameter for whatever you want
- You can choose to discard the message after processing it (like in the included popular "MinMaxInfo" example which limits how much you can resize a form)
The ActiveX DLL is only required during development and you don't need to include it with your final executables. You can also choose to process all incoming messages or only a select few that you are interested in.
Here's the code for the test project. It tackles the following messages:
- WM_LBUTTONUP (generates a run-time error on form click to allow manual debugging or stopping)
- WM_CONTEXTMENU (displays a PopupMenu on right-click, pressing the menu key or Shift-F10)
- WM_HOTKEY (responds to the Ctrl-Alt-Backspace hotkey as an example)
- WM_GETMINMAXINFO (allows resizing the form only within well defined confines).
frmSafeSubclassingTest.frm
This is the code for the ActiveX DLL:
cSC.cls
mdlSC.bas
Here's the demo project including the ActiveX DLL (you need to compile it): SafeSubclassing.zip
It turns out that all it takes to make the IDE completely crash-proof is to replace the implementation of the "ISubclass" interface with regular run-of-the-mill VB6 events. Now you can safely debug your code, click "Stop" or "End" and everything just works the same as it would with a VB6 native event (like "Form_Click" for example). It also provides a couple of advantages over regular events:
- You can use the additional "dwRefData" parameter for whatever you want
- You can choose to discard the message after processing it (like in the included popular "MinMaxInfo" example which limits how much you can resize a form)
The ActiveX DLL is only required during development and you don't need to include it with your final executables. You can also choose to process all incoming messages or only a select few that you are interested in.
Here's the code for the test project. It tackles the following messages:
- WM_LBUTTONUP (generates a run-time error on form click to allow manual debugging or stopping)
- WM_CONTEXTMENU (displays a PopupMenu on right-click, pressing the menu key or Shift-F10)
- WM_HOTKEY (responds to the Ctrl-Alt-Backspace hotkey as an example)
- WM_GETMINMAXINFO (allows resizing the form only within well defined confines).
frmSafeSubclassingTest.frm
Code:
#If bInIDE Then
Private WithEvents Subclass As prjSafeSubclassing.cSC
#Else
Private WithEvents Subclass As cSC
#End If
Private Sub Form_Activate()
Print vbNewLine & " Right click on the form to display the context menu!" & vbLf & " Left click on the form for ""Division by zero"" in IDE!" & vbLf & " Drag edges to resize the form within its confines!"
End Sub
Private Sub Form_Load()
#If bInIDE Then
Set Subclass = New prjSafeSubclassing.cSC
#Else
Set Subclass = New cSC
#End If
With tMinMaxSize
.MinWidth = ScaleX(Width, ScaleMode, vbPixels): .MinHeight = ScaleY(Height, ScaleMode, vbPixels)
.MaxWidth = .MinWidth * 2: .MaxHeight = .MinHeight * 2
End With
RegisterHotKey hWnd, &HABCD&, MOD_ALT Or MOD_CONTROL, vbKeyBack
Subclass.SubclassWnd hWnd, Array(WM_LBUTTONUP, WM_CONTEXTMENU, WM_HOTKEY, WM_GETMINMAXINFO)
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnregisterHotKey hWnd, &HABCD&
End Sub
Private Sub mnuContextOptions_Click(Index As Integer)
Select Case Index
Case 0: frmModal.Show vbModal
Case 1: If Subclass.IsWndSubclassed(hWnd) Then Subclass.UnSubclassWnd hWnd
Case 3: Unload Me
End Select
End Sub
Private Sub CheckMinMaxInfo(tMinMaxInfo As MINMAXINFO, ByVal lParam As Long)
PutMem4 ByVal VarPtr(lParam) - 4, lParam
With tMinMaxInfo
.ptMinTrackSize.X = tMinMaxSize.MinWidth: .ptMinTrackSize.Y = tMinMaxSize.MinHeight
.ptMaxTrackSize.X = tMinMaxSize.MaxWidth: .ptMaxTrackSize.Y = tMinMaxSize.MaxHeight
End With
End Sub
Private Sub Subclass_MessageReceived(hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, dwRefData As Long, bDiscardMessage As Boolean, lReturnValue As Long)
Select Case uMsg
Case WM_LBUTTONUP
Debug.Print 1 \ 0 ' Run-time error 11: Division by zero. We can safely debug and skip past this error in IDE or click "End"
Case WM_CONTEXTMENU
PopupMenu mnuContext, vbPopupMenuRightButton
Case WM_HOTKEY
If (lParam And &HFFFF&) = (MOD_ALT Or MOD_CONTROL) Then
Select Case lParam \ 65536
Case vbKeyBack ' Press Ctrl-Alt-Backspace to quit (the form doesn't need to be in the foreground)!
Unload Me
End Select
End If
Case WM_GETMINMAXINFO
CheckMinMaxInfo tMinMaxInfo, lParam: bDiscardMessage = True ' We can resize the form only within its confines defined in Form_Load
End Select
End SubcSC.cls
Code:
Option Explicit
Private colSubclasses As Collection, uIdSubclass As Long, bCustomMessages As Boolean, lCustomMsg1 As Long, lCustomMsg2 As Long, lCustomMsg3 As Long, lCustomMsg4 As Long, lCustomMsg5 As Long
Public Event MessageReceived(hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, dwRefData As Long, bDiscardMessage As Boolean, lReturnValue As Long)
Public Function IsWndSubclassed(hWnd As Long, Optional dwRefData As Long) As Boolean
IsWndSubclassed = mdlSC.IsWndSubclassed(hWnd, uIdSubclass, dwRefData)
End Function
Public Function SubclassWnd(hWnd As Long, Optional vCustomMessages As Variant, Optional dwRefData As Long, Optional bUpdateRefData As Boolean) As Boolean
Dim i As Long
SubclassWnd = mdlSC.SubclassWnd(hWnd, uIdSubclass, dwRefData, bUpdateRefData)
If SubclassWnd And Not bUpdateRefData Then
colSubclasses.Add hWnd, CStr(hWnd)
If Not IsMissing(vCustomMessages) Then ' Process up to five custom messages
If Not IsArray(vCustomMessages) Then vCustomMessages = Array(vCustomMessages)
For i = LBound(vCustomMessages) To UBound(vCustomMessages)
Select Case i + 1
Case 1: lCustomMsg1 = vCustomMessages(i)
Case 2: lCustomMsg2 = vCustomMessages(i)
Case 3: lCustomMsg3 = vCustomMessages(i)
Case 4: lCustomMsg4 = vCustomMessages(i)
Case 5: lCustomMsg5 = vCustomMessages(i)
End Select
Next i
bCustomMessages = True
Else ' Process all messages
bCustomMessages = False
End If
End If
End Function
Public Function UnSubclassWnd(hWnd As Long) As Boolean
UnSubclassWnd = mdlSC.UnSubclassWnd(hWnd, uIdSubclass): If UnSubclassWnd Then colSubclasses.Remove CStr(hWnd)
End Function
Friend Function WndProc(hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, dwRefData As Long, bDiscardMessage As Boolean) As Long
Select Case uMsg
Case lCustomMsg1, lCustomMsg2, lCustomMsg3, lCustomMsg4, lCustomMsg5
RaiseEvent MessageReceived(hWnd, uMsg, wParam, lParam, dwRefData, bDiscardMessage, WndProc)
Case Else
If Not bCustomMessages Then RaiseEvent MessageReceived(hWnd, uMsg, wParam, lParam, dwRefData, bDiscardMessage, WndProc) ' Process all messages if we didn't specify any custom ones
End Select
End Function
Private Sub Class_Initialize()
Set colSubclasses = New Collection: uIdSubclass = ObjPtr(Me)
End Sub
Private Sub Class_Terminate()
Dim hWnd As Variant
If colSubclasses.Count Then Beep ' Beep on abnormal termination as a reminder of the goold ol' days when it used to crash!
For Each hWnd In colSubclasses ' Safely remove subclassing if the "Stop" or "End" buttons were clicked
UnSubclassWnd CLng(hWnd)
Next hWnd
End SubCode:
Option Explicit
Private Const WM_NCDESTROY As Long = &H82
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Public Function IsWndSubclassed(hWnd As Long, uIdSubclass As Long, Optional dwRefData As Long) As Boolean
IsWndSubclassed = GetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
End Function
Public Function SubclassWnd(hWnd As Long, uIdSubclass As Long, Optional dwRefData As Long, Optional bUpdateRefData As Boolean) As Boolean
Dim lOldRefData As Long
If Not IsWndSubclassed(hWnd, uIdSubclass, lOldRefData) Then
SubclassWnd = SetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
Else
If bUpdateRefData Then If lOldRefData <> dwRefData Then SubclassWnd = SetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
End If
End Function
Public Function UnSubclassWnd(hWnd As Long, uIdSubclass As Long) As Boolean
If IsWndSubclassed(hWnd, uIdSubclass) Then UnSubclassWnd = RemoveWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass)
End Function
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Subclass As cSC, ByVal dwRefData As Long) As Long
Dim bDiscardMessage As Boolean
Select Case uMsg
Case WM_NCDESTROY ' Remove subclassing as the window is about to be destroyed
Subclass.UnSubclassWnd hWnd
Case Else
WndProc = Subclass.WndProc(hWnd, uMsg, wParam, lParam, dwRefData, bDiscardMessage) ' bDiscardMessage is passed ByRef so it can be toggled as required by each local Subclass_WndProc
End Select
If Not bDiscardMessage Then WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam) ' Choose whether to pass along this message or discard it
End Function