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, http://www.mabry.com
'
' Used at VBnet by permission.
' For the latest version see the Tools section at http://www.mvps.org/vb/
' *************************************************************************
' 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 |
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)
Else
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
Case WM_SYSCOMMAND
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 |
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.
