Subclassing... An advanced topic that has become much easier over the years. About the only thing that can be considered advanced nowadays is the added research subclassing requires to properly handle messages and retrieving structures and data related to some pointer the subclass procedures receives.
What is posted here is simply a working, drop-in, collection of code that can be added to any project. Subclassed messages can be received in a form, class, usercontrol or property page. The code provided is specifically designed for the subclassing functions provided by the common controls library (comctl32.dll). It does not require manifesting or adding the Windows Common Control ocx to your project. The provided code is targeted for projects, not stand-alone classes, therefore, requires the bas module and separate implementation class below.
Content of modSubclasser follows
Content of ISubclassEvent follows
A simple sample. Have form subclass one of its textboxes
Side note. I have created several versions of IDE-safe subclassing routines over the years and all but two were based off of Paul Caton's ideas/code that used assembly thunks as a go-between. So I do have lots of experience with subclassing. The functions provided in comctl32.dll are theoretically IDE-safe. I personally find that the IDE is more responsive with the thunk version vs. these comctl32 functions. No code is truly IDE-safe if it is poorly written. As always, save often when debugging while subclassing. These comctl32 functions do make setting up subclassing a breeze.
Edited: Changed keying to allow unsubclassing all windows by a specific Receiver, at once. Useful should you want to terminate subclassed hWnds in one call vs. one at a time. Other minor tweaks were also made. FYI: Keys are in this format: [8 chars][8 chars][key] where 1st 8 chars is Hex value of Receiver, 2nd 8 chars is Hex value of subclassed hWnd & the [key] is the user-provided key, if any. This Key structure allows unsubclassing all windows with only knowing the Receiver and/or unsubclassing a hWnd without knowing the Receiver(s) that subclassed it.
If needed, you can add this to the module to retrieve the Key you assigned to a specific instance of subclassing:
What is posted here is simply a working, drop-in, collection of code that can be added to any project. Subclassed messages can be received in a form, class, usercontrol or property page. The code provided is specifically designed for the subclassing functions provided by the common controls library (comctl32.dll). It does not require manifesting or adding the Windows Common Control ocx to your project. The provided code is targeted for projects, not stand-alone classes, therefore, requires the bas module and separate implementation class below.
Content of modSubclasser follows
Code:
'----- modSubclasser ---------------------------------------------------------------------
' This module can be added to any project. Its declarations are all private and should
' not cause any conflicts with any existing code already in your project.
' To use this module to subclass windows, very little overhead is needed:
' 1) Add this module to your project
' 2) Add the ISubclassEvent class to your project
' 3) In whatever code page (form/class/usercontrol/propertypage) that you want to
' receive subclassed messages, add this in the declarations section of the code page:
' Implements ISubclassEvent
' 4) As needed, call the SubclassWindow() method in this module
' 5) When subclassing no longer needed, call the UnsubclassWindow() method
'-----------------------------------------------------------------------------------------
Option Explicit
' comctl32 versions less than v5.8 have these APIs, but they are exported via Ordinal
Private Declare Function SetWindowSubclassOrdinal Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function DefSubclassProcOrdinal Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function RemoveWindowSubclassOrdinal Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
' comctl32 versions 5.8+ exported the APIs by name
Private Declare Function DefSubclassProc Lib "comctl32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function IsWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function DefWindowProcA Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProcW Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcAddressOrdinal Lib "kernel32.dll" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Const WM_DESTROY As Long = &H2
Private m_SubclassKeys As Collection
Private m_UseOrdinalAliasing As Boolean
Public Function SubclassWindow(ByVal hWnd As Long, Receiver As ISubclassEvent, Optional ByVal Key As String) As Boolean
' can subclass multiple windows simultaneously
' see ISubclassEvent comments for helpful tips regarding the Receiver's event
' hWnd: The window handle & must be in the same process
' Receiver: The form/class/usercontrol/propertypage that Implements ISubclassEvent
' and wants to receive messages for the hWnd. Receiver MUST NOT be destroyed before
' all subclassing it is recieving are first released. If unsure, you should call
' the following in its Terminate or Unload event: UnsubclassWindow -1&, Me
' Key: unique key used to identify this specific instance of subclassing
' Key is passed to each subclass event and can be used to filter subclassed
' messages. Keys are unique per Receiver
' Recommend always assigning a key if subclassing multiple windows.
' Function fails in any of these cases:
' hWnd is not valid or is not in the same process as project
' Receiver is Nothing
' Key is duplicated
' Trying to subclass the same window twice with the same Receiver
If Receiver Is Nothing Or hWnd = 0& Then Exit Function
Dim lValue As Long
Key = Right$("0000" & Hex(ObjPtr(Receiver)), 8) & Right$("0000" & Hex(hWnd), 8) & Key
If m_SubclassKeys Is Nothing Then
lValue = LoadLibrary("comctl32.dll")
If lValue = 0& Then Exit Function ' comctl32.dll doesn't exist
m_UseOrdinalAliasing = False
If GetProcAddress(lValue, "SetWindowSubclass") = 0& Then
If GetProcAddressOrdinal(lValue, 410&) = 0& Then
FreeLibrary lValue ' comctl32.dll is very old
Exit Function
End If
m_UseOrdinalAliasing = True
End If
FreeLibrary lValue
Set m_SubclassKeys = New Collection
Else
On Error Resume Next
lValue = Len(m_SubclassKeys(CStr(ObjPtr(Receiver) Xor hWnd)))
If Err Then
Err.Clear
Else
Exit Function ' duplicate key
End If
On Error GoTo 0
End If
If IsWindow(hWnd) = 0 Then Exit Function ' not a valid window
If Not GetWindowThreadProcessId(hWnd, lValue) = App.ThreadID Then Exit Function
lValue = ObjPtr(Receiver) Xor hWnd
m_SubclassKeys.Add Key, CStr(lValue)
If m_UseOrdinalAliasing Then
SetWindowSubclassOrdinal hWnd, AddressOf pvWndProc, lValue, ObjPtr(Receiver)
Else
SetWindowSubclass hWnd, AddressOf pvWndProc, lValue, ObjPtr(Receiver)
End If
SubclassWindow = True
End Function
Public Function UnsubclassWindow(ByVal hWnd As Long, Receiver As ISubclassEvent, Optional ByVal Key As String) As Boolean
' should be called when the subclassing is no longer needed
' this will be called automatically if the subclassed window is about to be destroyed
' To remove all subclassing for the Reciever, pass hWnd as -1&
' Function fails in these cases
' hWnd was not subclassed or is invalid
' Receiver did not subclass the hWnd
' Key is invalid
Dim lID As Long, lRcvr As Long
If Receiver Is Nothing Or hWnd = 0& Then Exit Function
lRcvr = ObjPtr(Receiver)
If hWnd = -1& Then
For lID = m_SubclassKeys.Count To 1& Step -1&
If CLng("&H" & Left$(m_SubclassKeys(lID), 8)) = lRcvr Then
hWnd = CLng("&H" & Mid$(m_SubclassKeys(lID), 9, 8))
Call UnsubclassWindow(hWnd, Receiver, Mid$(m_SubclassKeys(lID), 17))
End If
Next
UnsubclassWindow = True
Exit Function
End If
On Error Resume Next
lID = lRcvr Xor hWnd
Key = Right$("0000" & Hex(lRcvr), 8) & Right$("0000" & Hex(hWnd), 8) & Key
If Key = m_SubclassKeys(CStr(lID)) Then
If Err Then
Err.Clear
Exit Function
End If
If m_UseOrdinalAliasing Then
lID = RemoveWindowSubclassOrdinal(hWnd, AddressOf pvWndProc, lID)
Else
lID = RemoveWindowSubclass(hWnd, AddressOf pvWndProc, lID)
End If
If lID Then
UnsubclassWindow = True
m_SubclassKeys.Remove CStr(lRcvr Xor hWnd)
If m_SubclassKeys.Count = 0& Then Set m_SubclassKeys = Nothing
End If
End If
End Function
Private Function pvWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, _
ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Dim lAction As enumSubclassActions, bRtn As Boolean, sKey As String
Dim IReceiver As ISubclassEvent, tObj As Object
sKey = Mid$(m_SubclassKeys(CStr(uIdSubclass)), 17)
RtlMoveMemory tObj, dwRefData, 4&
Set IReceiver = tObj
RtlMoveMemory tObj, 0&, 4&
pvWndProc = IReceiver.ProcessMessage(sKey, hWnd, uMsg, wParam, lParam, lAction, bRtn, 0&)
If uMsg = WM_DESTROY Then
lAction = scevForwardMessage
bRtn = False
UnsubclassWindow hWnd, IReceiver, sKey
End If
If lAction = scevDoNotForwardEvent Then
Exit Function
ElseIf lAction = scevForwardMessage Then
If m_UseOrdinalAliasing Then
pvWndProc = DefSubclassProcOrdinal(hWnd, uMsg, wParam, lParam)
Else
pvWndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End If
ElseIf IsWindowUnicode(hWnd) Then
pvWndProc = DefWindowProcW(hWnd, uMsg, wParam, lParam)
Else
pvWndProc = DefWindowProcA(hWnd, uMsg, wParam, lParam)
End If
If bRtn Then Call IReceiver.ProcessMessage(sKey, hWnd, uMsg, wParam, lParam, scevDoNotForwardEvent, True, (pvWndProc))
End FunctionCode:
'----- ISubclassEvent ---------------------------------------------------------------------
' Ensure this class is named ISubclassEvent
'-----------------------------------------------------------------------------------------
Option Explicit
Public Enum enumSubclassActions
scevForwardMessage = 0 ' continue the message down the subclassing chain
scevSendToOriginalProc = 1 ' skip the chain & send message directly to original window procedure
scevDoNotForwardEvent = -1 ' do not forward this message any further down the chain
End Enum
Public Function ProcessMessage(ByVal Key As String, ByVal hWnd As Long, ByVal Message As Long, _
ByRef wParam As Long, ByRef lParam As Long, ByRef Action As enumSubclassActions, _
ByRef WantReturnMsg As Boolean, ByVal ReturnValue As Long) As Long
' Key. The Key provided during the SubclassWindow() call
' hWnd. The subclassed window's handle
' Message. The message to process
' wParam & lParam. Message-specific values
' Action. Action to be taken after you process this message
' WantReturnMsg. Set to True if want to monitor the result after message completely processed
' ReturnValue. The final result of the message and passed only when WantReturnMsg = True
' Notes
' WantReturnMsg. This parameter serves two purposes:
' 1) Indication whether this message is received BEFORE other subclassers have received
' it or AFTER the last subclasser has processed the message.
' If parameter = False, this is a BEFORE event
' If parameter = True, this is an AFTER event
' 2) Allows you to request an AFTER event. Set parameter to True during the BEFORE event.
' Parameter is ignored if Action is set to scevDoNotForwardEvent in the BEFORE event.
' When WantReturnMsg is set to True, after the subclassing chain processes the
' message, you will get a second event. The WantReturnMsg parameter will be True
' and the ReturnValue parameter will contain the final result. This is the AFTER event.
' wParam & lParam can be changed by you. Any changes are forwarded down the chain as necessary
' Key parameter, if set, is very useful if subclassing multiple windows at the same time.
' All subclassed messages for the same object implementing this class receives all messages
' for each subclassed window thru this same event. To make it simpler to determine which
' hWnd relates to what type of window, the Key can be used.
' The return value of this function is only used if Action is set to scevDoNotForwardEvent
End FunctionCode:
Option Explicit
Implements ISubclassEvent
Private Sub cmdSubclass_Click()
SuclassWindow Text1.hWnd, Me, "txt1"
End Sub
Private Sub cmdUnSubclass_Click()
UnsubclassWindow Text1.hwnd, Me, "txt1"
End Sub
Private Function ISubclassEvent_ProcessMessage(ByVal Key As String, ByVal hWnd As Long, _
ByVal Message As Long, wParam As Long, lParam As Long, _
Action As enumSubclassActions, WantReturnMsg As Boolean, _
ByVal ReturnValue As Long) As Long
Select Case Message
...
End Select
End FunctionEdited: Changed keying to allow unsubclassing all windows by a specific Receiver, at once. Useful should you want to terminate subclassed hWnds in one call vs. one at a time. Other minor tweaks were also made. FYI: Keys are in this format: [8 chars][8 chars][key] where 1st 8 chars is Hex value of Receiver, 2nd 8 chars is Hex value of subclassed hWnd & the [key] is the user-provided key, if any. This Key structure allows unsubclassing all windows with only knowing the Receiver and/or unsubclassing a hWnd without knowing the Receiver(s) that subclassed it.
If needed, you can add this to the module to retrieve the Key you assigned to a specific instance of subclassing:
Code:
Public Function GetSubclassKey(ByVal hWnd As Long, Receiver As ISubclassEvent) As String
On Error Resume Next
GetSubclassKey = Mid$(m_SubclassKeys(CStr(ObjPtr(Receiver) Xor hWnd)), 17)
If Err Then Err.Clear
End Function