Scribd
Upload
3 views2 pages

User32 Library Window Procedure Handling

This document contains code for subclassing a control in VBA. It declares functions for getting and setting window properties. It defines a SubclassControl function to subclass a control and redirect its window messages. It includes a WndProc function that handles the messages and calls the control's WndProc.

Uploaded by

opdbslnn
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
3 views2 pages

User32 Library Window Procedure Handling

This document contains code for subclassing a control in VBA. It declares functions for getting and setting window properties. It defines a SubclassControl function to subclass a control and redirect its window messages. It includes a WndProc function that handles the messages and calls the control's WndProc.

Uploaded by

opdbslnn
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd

' in module

Private Declare Function vbaObjSetAddref Lib "[Link]" Alias


"__vbaObjSetAddref" (dstObject As Any, srcObjPtr As Any) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal
hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal
hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long,
ByVal lpString As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long,
ByVal lpString As Long, ByVal hData As Long) As Long
Public 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

Private Const GWL_USERDATA As Long = (-21)


Public Const GWL_WNDPROC As Long = (-4)

Public Function SubclassControl(Control As Class1) As Long


SetWindowLong [Link], GWL_USERDATA, ObjPtr(Control)
SubclassControl = SetWindowLong([Link], GWL_WNDPROC, AddressOf WndProc)
SetProp [Link], StrPtr("prev"), SubclassControl
End Function

Private Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
Dim ctl As Class1
On Error GoTo ErrLabel
vbaObjSetAddref ctl, ByVal GetWindowLong(hWnd, GWL_USERDATA)
WndProc = [Link](hWnd, Msg, wParam, lParam)
Set ctl = Nothing
Exit Function

ErrLabel:
If [Link] = &H80010007 Then
SetWindowLong hWnd, GWL_WNDPROC, GetProp(hWnd, StrPtr("prev"))
End If
Set ctl = Nothing
End Function

'in class

Option Explicit

Public Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
End Function

Public Property Get hWnd() As Long


End Property

'in control
Implements Class1
Dim prevProc As Long

Private Property Get Class1_hWnd() As Long


Class1_hWnd = hWnd
End Property

Private Sub UserControl_Initialize()


prevProc = SubclassControl(Me)
End Sub

Private Sub UserControl_Terminate()


SetWindowLong hWnd, GWL_WNDPROC, prevProc
End Sub

Private Function Class1_WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam
As Long, ByVal lParam As Long) As Long
'
Select Case Msg
Case &H20A&
Label1 = Time
Case Else
Class1_WndProc = CallWindowProc(prevProc, hWnd, Msg, wParam, lParam)
End Select

End Function

You might also like