dcsimg
December 6, 2016
Hot Topics:

Size Up Your Applications with Subclassing

  • November 19, 2002
  • By Sam Huggill
  • Send Email »
  • More Articles »

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




Page 2 of 4



Comment and Contribute

 


(Maximum characters: 1200). You have characters left.

 

 


Enterprise Development Update

Don't miss an article. Subscribe to our newsletter below.

Sitemap | Contact Us

Thanks for your registration, follow us on our social networks to keep up-to-date
Rocket Fuel