[VB6] Subclassing With Common Controls Library

**LaVolpe** · Feb 8th, 2015, 02:50 PM

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

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 GetClassLongA Lib "user32.dll" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetClassLongW Lib "user32.dll" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProcW Lib "user32.dll" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallWindowProcA Lib "user32.dll" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam 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 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 Const GCL_WNDPROC As Long = -24

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: passed to each subclass event and can be used to filter subclassed
    '   messages/hWnds. Keys are not case-sensitive & are for your use only
    ' 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
    '   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, lRcvr As Long
    If IsWindow(hWnd) = 0 Then Exit Function    ' not a valid window
    If Not GetWindowThreadProcessId(hWnd, lValue) = App.ThreadID Then Exit Function
    
    lRcvr = ObjPtr(Receiver)
    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
        If Len(m_SubclassKeys(CStr(lRcvr Xor hWnd))) > 0& Then
            If Err Then
                Err.Clear
            Else
                Exit Function                   ' hWnd already subclassed by Receiver
            End If
        End If
        On Error GoTo 0
    End If
    
    Key = Right$("0000" & Hex(lRcvr), 8) & Right$("0000" & Hex(hWnd), 8) & Key
    lValue = lRcvr Xor hWnd
    m_SubclassKeys.Add Key, CStr(lValue)
    If m_UseOrdinalAliasing Then
        SubclassWindow = SetWindowSubclassOrdinal(hWnd, AddressOf pvWndProc, lValue, lRcvr)
    Else
        SubclassWindow = SetWindowSubclass(hWnd, AddressOf pvWndProc, lValue, lRcvr)
    End If
    If SubclassWindow = False Then m_SubclassKeys.Remove CStr(lValue)
    
End Function

Public Function UnsubclassWindow(ByVal hWnd As Long, Receiver As ISubclassEvent) 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

    Dim lID As Long, lRcvr As Long
    If Receiver Is Nothing Or m_SubclassKeys Is Nothing Then Exit Function
    If m_SubclassKeys.Count = 0& 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)
            End If
        Next
        UnsubclassWindow = True
    Else
        On Error Resume Next
        lID = lRcvr Xor hWnd
        If Len(m_SubclassKeys(CStr(lID))) > 0 Then
            If Err Then
                Err.Clear
                Exit Function                   ' hWnd not subclassed by this Receiver
            End If
            If m_UseOrdinalAliasing Then
                UnsubclassWindow = RemoveWindowSubclassOrdinal(hWnd, AddressOf pvWndProc, lID)
            Else
                UnsubclassWindow = RemoveWindowSubclass(hWnd, AddressOf pvWndProc, lID)
            End If
            If UnsubclassWindow Then
                m_SubclassKeys.Remove CStr(lID)
                If m_SubclassKeys.Count = 0& Then Set m_SubclassKeys = Nothing
            End If
        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
    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 = CallWindowProcW(GetClassLongW(hWnd, GCL_WNDPROC), hWnd, uMsg, wParam, lParam)
    Else
        pvWndProc = CallWindowProcA(GetClassLongA(hWnd, GCL_WNDPROC), hWnd, uMsg, wParam, lParam)
    End If
    If bRtn Then Call IReceiver.ProcessMessage(sKey, hWnd, uMsg, wParam, lParam, scevDoNotForwardEvent, bRtn, pvWndProc)
    
End Function

Content of ISubclassEvent follows

Code:

'----- 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 Function

A simple sample. Have form subclass one of its textboxes

Code:

Option Explicit
Implements ISubclassEvent

Private Sub cmdSubclass_Click()
    SubclassWindow 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 Function

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: Updated to handle bug reported by Bonnie in post #7 regarding skipping straight to original procedure. Also removed requirement to pass Key when unsubclassing.

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

**wqweto** · Feb 8th, 2015, 03:19 PM

No subclassing module can be called IDE-safe if it's not using EbMode function to check if IDE is in break mode.

The funny thing is Paul and I collaborated on the second version of his subclasser where I had to completely rewrite the assembly thunk and still through the years the only subclassing that I'm using in production is Matt Curland's DbgWProc.dll (and DbgHProc.dll) which are the grand daddy of the EbMode hack.

cheers,
</wqw>

**LaVolpe** · Feb 8th, 2015, 03:25 PM

Originally Posted by wqweto

No subclassing module can be called IDE-safe if it's not using EbMode function to check if IDE is in break mode.

Have to agree for the most part. Though outsourcing subclassing to an external DLL can make it IDE safe. I've done it and the only thing that crashed it was purposely writing to bad memory locations. And that had to be specific also, as I had the DLL handle first/second chance errors the best it could.

Anyway, I personally don't care whether any solution is truly IDE safe. Once you've got the code written, the EbMode hack is out the window once compiled. However, any levels of IDE-safeness are indispensable to novices.

P.S. Glad you posted that link. Didn't know you were Vlad. We've talked a bit while we were both regulars on PSC & that was so very long ago.

**VBClassicRocks** · Feb 9th, 2015, 08:08 AM

Keith, thanks for sharing.
One small nit:
SuclassWindow Text1.hWnd, Me, "txt1"

**LaVolpe** · Feb 9th, 2015, 08:36 AM

Originally Posted by VBClassicRocks

Keith, thanks for sharing.
One small nit:
SuclassWindow Text1.hWnd, Me, "txt1"

Typos, gotta love 'em. Fixed. Thanx.
Also tweaked it to make testing for the key case-insensitive within the UnsubclassWindow routine.

**LaVolpe** · Feb 9th, 2015, 10:07 AM

FYI to all. About using the Key parameter in the SubclassWindow() function...

Let's say you are subclassing 3 textboxes to prevent, modify, or replace the popup menu when someone right clicks on them. You are also subclassing your form to restrict minimum size a user can resize your form to and also to listen for system-wide broadcast messages sent to top-level windows. This means you'll be getting 4 sets of window messages in your subclass event: your form + 3 textboxes. Keys can be very useful here as shown below.

Code:

Private Sub Form_Load()
    SubclassWindow Me.hWnd, Me, "self"
    SubclassWindow Text1.hWnd, Me, "tBox"
    SubclassWindow Text2.hWnd, Me, "tBox"
    SubclassWindow Text3.hWnd, Me, "tBox"
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

    If Key = "self" Then
        Select Case Message   ' optionally, you can call some private function to handle form-related messages
            ...
        End Select

    ElseIf Key = "tBox" Then   ' all 3 textboxes have the same key because all 3 will be handled exactly the same
        Select Case Message
            ...
        End Select
    End If
End Function

Keys are for your use only. However, if used, you must also pass the key to the UnsubclassWindow() function when time comes to stop subclassing.

Note to self: remove requirement of passing the key -- done & updated in original post

**Bonnie West** · Feb 9th, 2015, 11:29 AM

Hope you don't mind several more comments...

The SubclassWindow function should probably return True only if the SetWindowSubclass API actually succeeded (returned TRUE).
There's no need for the IsWindow and GetWindowThreadProcessId tests since SetWindowSubclass already checks for those (i.e., it will return FALSE if the specified hWnd doesn't exist anymore or if it is from another process).
According to Olaf, VB6 already performs LoadLibrary and GetProcAddress calls the first time it invokes a Declare'd API function or sub (subsequent invocations use the cached return value of GetProcAddress), so doing it manually is somewhat redundant. If the requested API function is missing, VB6 will raise the trappable Error 453 (Specified DLL function not found).
In the pvWndProc function, the dwRefData parameter, which contains a pointer to an ISubclassEvent object, can be automatically cast to that object by simply changing its data type to the object it points to:
Code:
```
... Function pvWndProc(... , ByVal dwRefData As ISubclassEvent) ...
```
This technique also works for other types of callback procedures, provided that the callback signature includes at least 1 pointer-size user-defined parameter.
One beneficial side-effect of that automatic casting is that 2 local variables are no longer needed (IReceiver and tObj). The use of local variables in subclass procedures should be avoided as much as possible because they will still be allocated even for messages that aren't being handled there. As stated in the Structure of a Window Procedure:

Originally Posted by MSDN

Because it is possible to call a window procedure recursively, it is important to minimize the number of local variables that it uses. When processing individual messages, an application should call functions outside the window procedure to avoid excessive use of local variables, possibly causing the stack to overflow during deep recursion.

Regarding the handling of individual messages in separate procedures, a trick I sometimes employ when the message I'm processing has a parameter that points to some system-allocated structure, is using CallWindowProc to perform parameter casting in a manner similar to this example:

Code:

SetWindowSubclass(. . . , AddressOf SubclassProc, AddressOf GetMinMaxInfo, . . .)
. . .
Function SubclassProc(. . . , ByVal lParam As Long, ByVal uIdSubclass As Long, . . .) . . .
. . .
Case WM_GETMINMAXINFO
    SubclassProc = CallWindowProcW(uIdSubclass, hWnd, uMsg, wParam, lParam)
. . .
Function GetMinMaxInfo(. . . , ByRef lParam As MINMAXINFO) . . .

This avoids the overhead of duplicating data.

When I specified scevSendToOriginalProc for the Action parameter in your subclassing example, the TextBox was prevented from processing almost all user input. Was that supposed to happen? It's my understanding that the original window procedure is the one that was assigned to the WNDCLASS/WNDCLASSEX structure's lpfnWndProc member. If that was what you were referring to when you wrote "send message directly to original window procedure", then the DefWindowProc function is probably not the right API. According to the Default Window Procedure:

Originally Posted by MSDN

The default window procedure function, DefWindowProc defines certain fundamental behavior shared by all windows. The default window procedure provides the minimal functionality for a window. An application-defined window procedure should pass any messages that it does not process to the DefWindowProc function for default processing.

I tried the following instead and it worked fine:
Code:
```
pvWndProc = CallWindowProc(GetClassLong(hWnd, GCL_WNDPROC), hWnd, uMsg, wParam, lParam)
```
In Raymond Chen's Safer subclassing article, he warns that "you must remove your window subclass before the window being subclassed is destroyed". I believe a large part of the reason is because SetWindowSubclass adds an entry (named "UxSubclassInfo") to the property list of the window being subclassed.

Originally Posted by MSDN

Before a window is destroyed (that is, before it returns from processing the WM_NCDESTROY message), an application must remove all entries it has added to the property list.

**LaVolpe** · Feb 9th, 2015, 12:00 PM

Bonnie. lots of comments...