I've just written a module to take some of the danger out of subclassing. I was wondering if anyone wanted the code, I'm pretty sure it's bug free but it would be really handy if someone went through the code to check if there are any errors which I've missed. also if anyone wants to tell me how I could change it to make it better and how usefull it would be that would be great.


How to use this code.

1 add a module to your project and put the module code below in it.

2 write the substitute window procedure, declare it like this

Code:
Public Function WindowProc (ByRef hWnd as long, ByRef wMsg as long, ByRef wParam as long, ByRef lParam as long,Byref Retval as long) as boolean

you can call it anything you like it dosn't have to be WindowProc

subclass a window like this

Subclass hWnd,Object,ProcName

where hWnd is the handle of the window you want to put the code in
Object is the object that the code for the windowprocedure is in
and ProcName is a string containing the name of your substitute window procedure

as the parameters are by reference you can change them to whatever you like very easily

you don't actually need to call the default window procedure, if you return False the module will call it for you, using the parameters as you changed them, if you want to change the return value of the window procedure then call the default window proc with

Code:
Retval=CallDefaultWindowProc (hWnd,wMsg,wParam,lParam)
and if you want to change the return value just change retval and return True to indivate that you've called the default window procedure.

I hpe this is usefull, Here's the code for the module

Code:
Option Explicit

'Constants
Const NOTINARRAY = -1
Const GWL_WNDPROC = (-4)
Const WM_DESTROY = &H2



'udts

Private Type udtWindowParams

    hwnd As Long
    DefWindowProc As Long
    Object As Object
    ProcName As String

End Type

'API Declares
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


Dim uWindows() As udtWindowParams

Private Function NewWindow(hwnd As Long) As Integer

If ArrayIndex(hwnd) = NOTINARRAY Then
    
    ReDim Preserve uWindows(LBound(uWindows) To UBound(uWindows) + 1)
    
    uWindows(UBound(uWindows)).hwnd = hwnd
    
    'return index of new member
    
    NewWindow = UBound(uWindows)
    
Else    'Just in case window is allready subclassed

    NewWindow = ArrayIndex(hwnd)
    
End If

End Function

Private Sub RemoveWindow(hwnd As Long)

Dim i As Integer
Dim intIndex As Integer
Dim uTemp() As udtWindowParams

intIndex = ArrayIndex(hwnd)

If intIndex = NOTINARRAY Then Exit Sub 'if window is not subclassed dont try to unsubclass it

ReDim uTemp(LBound(uWindows) To UBound(uWindows) - 1)

For i = LBound(uTemp) To UBound(uTemp)

    'fill temp array with old array data missing out intindex
    uTemp(i).hwnd = uWindows(IIf(i < intIndex, i, i + 1)).hwnd
    uTemp(i).DefWindowProc = uWindows(IIf(i < intIndex, i, i + 1)).DefWindowProc
Set uTemp(i).Object = uWindows(IIf(i < intIndex, i, i + 1)).Object
    uTemp(i).ProcName = uWindows(IIf(i < intIndex, i, i + 1)).ProcName

Next i

'redimension array
ReDim uWindows(LBound(uTemp) To UBound(uTemp))

'Refill array
For i = LBound(uWindows) To UBound(uWindows)

    uWindows(i).hwnd = uTemp(i).hwnd
    uWindows(i).DefWindowProc = uTemp(i).DefWindowProc
    uWindows(i).Object = uTemp(i).Object
    uWindows(i).ProcName = uTemp(i).ProcName

Next i

End Sub
Private Function ArrayIndex(hwnd As Long) As Integer

Dim i As Integer
'loop through array to find hwnd

On Error GoTo ARRAYNOTDIMENSIONED::

For i = LBound(uWindows) To UBound(uWindows)

    If uWindows(i).hwnd = hwnd Then
    
        ArrayIndex = i
        Exit Function
    
    End If

Next i

'If not found return NOTINARRAY constant
ArrayIndex = NOTINARRAY

Exit Function

ARRAYNOTDIMENSIONED::

ReDim uWindows(0 To 0)

ArrayIndex = NOTINARRAY

End Function


Public Sub SubClass(hwnd As Long, TargetObject As Object, ProcName As String)

Dim intIndex As Integer


If ArrayIndex(hwnd) = NOTINARRAY Then 'Check window is not already subclassed

    'create new arraymember to store data in
    intIndex = NewWindow(hwnd)
    
    'Subclass window and fill array members
Set uWindows(intIndex).Object = TargetObject
    uWindows(intIndex).ProcName = ProcName
    uWindows(intIndex).DefWindowProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)

End If

End Sub

Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim intIndex As Integer
Dim boolDefWinProcCalled As Boolean

'replacement Parameters
Dim lngTemphWnd As Long
Dim lngTempwMsg As Long
Dim lngTempwParam As Long
Dim lngTemplParam As Long
Dim lngTempRetval As Long


intIndex = ArrayIndex(hwnd)


On Error GoTo WINDOWPROCERROR::

If wMsg = WM_DESTROY Then GoTo WINDOWPROCERROR:: 'If window is closing unsubclass etc.

lngTemphWnd = hwnd
lngTempwMsg = wMsg
lngTempwParam = wParam
lngTemplParam = lParam

boolDefWinProcCalled = CallByName(uWindows(intIndex).Object, uWindows(intIndex).ProcName, VbMethod, _
                                  lngTemphWnd, lngTempwMsg, lngTempwParam, lngTemplParam, lngTempRetval)



If Not boolDefWinProcCalled Then

    lngTempRetval = CallDefaultWindowProc(lngTemphWnd, lngTempwMsg, lngTempwParam, lngTemplParam)

End If

WindowProc = lngTempRetval

Exit Function

WINDOWPROCERROR:: 'unsubclass window trying to do as lttle damage as possible

Debug.Print "Nope"

If Not boolDefWinProcCalled Then

    lngTempRetval = CallDefaultWindowProc(lngTemphWnd, lngTempwMsg, lngTempwParam, lngTemplParam)

End If

UnSubClass hwnd

WindowProc = lngTempRetval

End Function


Public Sub UnSubClass(hwnd As Long)

Dim intIndex As Integer

intIndex = ArrayIndex(hwnd)

If Not intIndex = NOTINARRAY Then 'If window is subclassed

    SetWindowLong hwnd, GWL_WNDPROC, uWindows(intIndex).DefWindowProc
    RemoveWindow hwnd

End If

End Sub

'CallDefaultWindowProc is a shameless API Wrapper Function to avoid API Calls in other objects
Public Function CallDefaultWindowProc(hwnd As Long, wMsg As Long, wParam As Long, lParam As Long) As Long

Dim intIndex As Integer

intIndex = ArrayIndex(hwnd)

If Not intIndex = NOTINARRAY Then

    CallDefaultWindowProc = CallWindowProc(uWindows(intIndex).DefWindowProc, hwnd, wMsg, wParam, lParam)

End If

End Function