[VB6] Subclassing With Common Controls Library

[LaVolpe]

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

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

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

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:

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