Visual Basic Subclassing Routines
WM_SYSCOMMAND: Change and Respond to a Customized System Menu
Posted:   Monday July 12, 1999
Updated:   Monday December 26, 2011
Applies to:   VB5, VB6
Developed with:   VB6, Windows 98
OS restrictions:   None
Author:   VBnet - Randy Birch

When the need to add items to a system menu is required, VB easily allows modification using the AppendMenu, ModifyMenu, SetMenuItemInfo and related APIs.  But getting the application to actually do something once the modification has been made becomes the responsibility of the subclassing routine. The method detailed here uses the MHookMe.bas module from Karl E. Peterson and Zane Thomas, and is used with permission.

This demo shows how to add a new menu item to a system menu, and respond to its activation using subclassing techniques.

 BAS Module Code
Place the following code into the general declarations area of a bas module:

Option Explicit
' Copyright 1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
' *************************************************************************
'  MHookMe.bas
'  Copyright (C)1997 Karl E. Peterson and Zane Thomas, All Rights Reserved
'  Distributed by Mabry Software,
'  Used at VBnet by permission.
'  For the latest version see the Tools section at
' *************************************************************************
'  Warning: This computer program is protected by copyright law and
'  international treaties. Unauthorized reproduction or distribution
'  of this program, or any portion of it, may result in severe civil
'  and criminal penalties, and will be prosecuted to the maximum
'  extent possible under the law.
' *************************************************************************

Public Declare Function GetProp Lib "User32" _
    Alias "GetPropA" _
   (ByVal hWnd As Long, ByVal lpString As String) 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 Declare Function SetProp Lib "User32" _
   Alias "SetPropA" _
  (ByVal hWnd As Long, ByVal lpString As String, _
   ByVal hData As Long) As Long
Private Declare Function SetWindowLong Lib "User32" _
   Alias "SetWindowLongA" _
  (ByVal hWnd As Long, ByVal nIndex As Long, _
   ByVal wNewWord As Long) As Long
Private Declare Function GetWindowLong Lib "User32" _
   Alias "GetWindowLongA" _
  (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, ByVal Length As Long)

Private Const GWL_WNDPROC  As Long = (-4)

Public Function HookFunc(ByVal hWnd As Long, ByVal msg As Long, _
                        ByVal wp As Long, ByVal lp As Long) As Long
  'this MUST be dimmed as the object passed!!!
   Dim obj As frmMain
   Dim foo As Long
   foo = GetProp(hWnd, "ObjectPointer")
  'Ignore "impossible" bogus case
   If (foo <> 0) Then
      CopyMemory obj, foo, 4
      On Error Resume Next
      HookFunc = obj.WindowProc(hWnd, msg, wp, lp)
      If (Err) Then
         UnhookWindow hWnd
         Debug.Print "Unhook on Error, #"; CStr(Err.Number)
         Debug.Print "  Desc: "; Err.Description
         Debug.Print "  Message, hWnd: &h"; Hex(hWnd), _
                             "Msg: &h"; Hex(msg), "Params:"; wp; lp
      End If

     'Make sure we don't get any foo->Release() calls
      foo = 0
      CopyMemory obj, foo, 4
   End If

End Function

Public Sub HookWindow(hWnd As Long, thing As Object)

   Dim foo As Long

   CopyMemory foo, thing, 4

   Call SetProp(hWnd, "ObjectPointer", foo)
   Call SetProp(hWnd, "OldWindowProc", GetWindowLong(hWnd, GWL_WNDPROC))
   Call SetWindowLong(hWnd, GWL_WNDPROC, AddressOf HookFunc)
End Sub

Public Sub UnhookWindow(hWnd As Long)
   Dim foo As Long

   foo = GetProp(hWnd, "OldWindowProc")
   If (foo <> 0) Then
      Call SetWindowLong(hWnd, GWL_WNDPROC, foo)
   End If
End Sub

Public Function InvokeWindowProc(hWnd As Long, msg As Long, _
                                 wp As Long, lp As Long) As Long

   InvokeWindowProc = CallWindowProc(GetProp(hWnd, "OldWindowProc"), _
                                     hWnd, msg, wp, lp)
End Function
 Form Code
Create a form with a single command button and a label. This form must be named frmMain (See the caveat in the HookFunc routine from the bas code above). Add a second form and name it frmAbout (for the demo I used the About form in the VB templates folder) and add the following code to the main form only. (If you choose not to name the form 'frmAbout', make sure that the name in the WindowProc routine below is changed!!)

Option Explicit

Private Const MF_STRING = &H0
Private Const WM_SYSCOMMAND = &H112
Private Const MF_SEPARATOR = &H800

'required: ID number for About command
'to be added to the system menu. This
'number must be less than '61440 int
'(&HF000 long)
Private Const ID_ABOUT = 1000

Private Declare Function GetSystemMenu Lib "User32" _
   (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function AppendMenu Lib "User32" _
    Alias "AppendMenuA" _
   (ByVal hMenu As Long, ByVal wFlags As Long, _
    ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long

Private Sub Command1_Click()

   Unload Me
End Sub

Private Sub Form_Load()

   Dim r As Long
   Dim hMenu As Long

  'Add an "About" command to the system menu
   hMenu = GetSystemMenu(Me.hWnd, False)
   r = AppendMenu(hMenu, MF_SEPARATOR, 0, 0&)
   r = AppendMenu(hMenu, MF_STRING, ID_ABOUT, "&About this Demo...")
  'if OK, then subclass the form to
  'catch this menuitem selection
   If r = 1 Then
      Label1.Caption = "Select About... from the system menu."
      Call HookWindow(Me.hWnd, Me)
      Label1.Caption = "About... was not added to the menu."
   End If
End Sub

Friend Function WindowProc(hWnd As Long, msg As Long, wp As Long, lp As Long) As Long

   Select Case msg
         If wp = ID_ABOUT Then
           'show the about form
            frmAbout.Show vbModal
            WindowProc = 1
            Exit Function
         End If

      Case Else
   End Select
  ' Pass along to default window procedure.
   WindowProc = CallWindowProc(GetProp(hWnd, "OldWindowProc"), hWnd, msg, wp, lp)
End Function

Private Sub Form_Unload(Cancel As Integer)

   Call UnhookWindow(Me.hWnd)

End Sub
Save then run the project using Start with Full Compile to catch any coding errors.  Once subclassed, the normal VB debugging mechanisms are pretty well unavailable. The label will indicate the success of adding the new menu item.  Clicking the item will display the form specified in the subclassing.


PayPal Link
Make payments with PayPal - it's fast, free and secure!


Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy


Hit Counter