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
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.Code:Retval=CallDefaultWindowProc (hWnd,wMsg,wParam,lParam)
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
