Size Up Your Applications with Subclassing

Tuesday Nov 19th 2002 by Sam Huggill
Share:

Size up your applications with subclassing

Are you including a statusbar just for a size grip? Want to know how to handle windows messages in VB? Find out all this right here.

This article will take you through setting up a subclassing module and intercepting windows messages to draw a size grip.

The first thing we need to do is to set up the subclassing module. Open VB, start a new Standard EXE Project and add a module. Rename the module modSubclass, and add the following code:

Option Explicit

' Holds a reference to the previous window
' procedure before we started subclassing

Public OldProc As Long
Public FrmHwnd As Long
Public FrmDC As Long

Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long

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 Declare Function InvalidateRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT, _
ByVal bErase As Long) As Long

Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long

Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long

Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _

ByVal lParam As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function PtInRect Lib "user32" _
(lpRect As RECT, _
ByVal ptY As Long, _
ByVal ptX As Long) As Long

Private Declare Function DrawFrameControl Lib "user32" _
(ByVal hDC As Long, _
lpRect As RECT, _
ByVal un1 As Long, _
ByVal un2 As Long) As Long

Private Declare Sub CopyMem Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)

Public Const GWL_WNDPROC = (-4)

' Messages to hook
Private Const WM_PAINT = &HF
Private Const WM_NCHITTEST = &H84
Private Const WM_SIZE = &H5

' Flags for DrawFrameControl
Private Const DFC_SCROLL = 3
Private Const DFCS_SCROLLSIZEGRIP = &H8

' Flags for GetSystemMetrics
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31

' WM_NCHITTEST and MOUSEHOOKSTRUCT Mouse Position Codes
Private Const HTBOTTOMRIGHT = 17
Private Const WM_ENTERSIZEMOVE = &H231
Private Const WM_EXITSIZEMOVE = &H232

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

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

Dim rc1 As RECT
Dim rc2 As RECT

Select Case wMsg

Case WM_SIZE
  Call GetClientRect(hwnd, rc2)
  If PtInRect(rc2, rc1.Left, rc1.Top) Then
    Call InvalidateRect(hwnd, rc1, True)
	frmMain.Refresh
  Else
    Call PostMessage(hwnd, WM_PAINT, 0, 0)
  End If
  WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
Case WM_PAINT
  WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
  Call GetClientRect(hwnd, rc1)
  rc1.Left = rc1.Right - GetSystemMetrics(SM_CXSIZE)
  rc1.Top = rc1.Bottom - GetSystemMetrics(SM_CYSIZE)
  Call DrawFrameControl(FrmDC, rc1, DFC_SCROLL, DFCS_SCROLLSIZEGRIP)
Case WM_NCHITTEST
  Call GetWindowRect(hwnd, rc2)
  rc2.Left = rc2.Right - GetSystemMetrics(SM_CXSIZE)
  rc2.Top = rc2.Bottom - GetSystemMetrics(SM_CYSIZE)
  If PtInRect(rc2, WordLo(lParam), WordHi(lParam)) Then
    WndProc = HTBOTTOMRIGHT
  Else
    WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
  End If
Case Else
  WndProc = CallWindowProc(OldProc, hwnd, wMsg, wParam, lParam)
End Select

End Function

Private Function WordHi(LongIn As Long) As Integer
Call CopyMem(WordHi, ByVal (VarPtr(LongIn) + 2), 2)
End Function

Private Function WordLo(LongIn As Long) As Integer
Call CopyMem(WordLo, ByVal VarPtr(LongIn), 2)
End Function

Now the hardcore stuff is out the way, we can test this out. Either add a new form or use the one provided, and copy the following code into it:

Option Explicit

Private Sub Form_Load()
' Start subclassing
FrmHwnd = Me.hwnd
FrmDC = Me.hDC
OldProc = GetWindowLong(FrmHwnd, GWL_WNDPROC)
SetWindowLong FrmHwnd, GWL_WNDPROC, AddressOf WndProc
End Sub

Private Sub Form_Unload(Cancel As Integer)
' End subclassing
SetWindowLong FrmHwnd, GWL_WNDPROC, OldProc
End Sub

Download the sample project

Share:
Home
Mobile Site | Full Site
Copyright 2017 © QuinStreet Inc. All Rights Reserved