Option Explicit
Public 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
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As _
Long, ByVal bRevert 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
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
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal ByteLen As Long)
Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As _
Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const SC_NEWMENU = 2
Public Const SC_MINIMIZE = &HF020
Public Const WM_SYSCOMMAND = &H112
Public Const WM_INITMENUPOPUP = &H117
Public Const BITMASK = &HFFFF0000
Public Const MF_STRING = &H0&
Public Const MF_SEPARATOR = &H800&
Public Const MF_GREYED = &H1&
Public Function FrmProc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'this allows each form to have its own window proc
'and hence to be able to access its own properties in the Win Proc
FrmProc = FrmFromHwnd(hwnd).WindowProc(hwnd, Msg, wParam, lParam)
End Function
Private Function FrmFromHwnd(hwnd As Long) As Object
Dim lo_Form As Object
Dim ll_Pointer As Long
'make function point to our subclassed form
ll_Pointer = GetWindowLong(hwnd, GWL_USERDATA)
CopyMemory lo_Form, ll_Pointer, 4
Set FrmFromHwnd = lo_Form
'don't forget to clean up afterwards!
CopyMemory lo_Form, 0&, 4
End Function
Form Code
Option Explicit
Private ml_OldWinProc As Long
Private Sub Form_Load()
AddAboutMenu
SubClass
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnSubClass
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim ll_SysMenu As Long
Select Case Msg
Case WM_SYSCOMMAND
'the user clicked on the new menu item
If wParam = SC_NEWMENU Then
' you can put here whatever you want to run when the menu is clicked
MsgBox "You've clicked the new item"
End If
Case WM_INITMENUPOPUP
'disable the menu option if the form is minimized. If you want
'that it will be enabled, remove the lines below from "If lParam ..."
'till "End If" that found 1 line above the "End Select"
If lParam And BITMASK Then
ll_SysMenu = GetSystemMenu(hwnd, 0)
If wParam = ll_SysMenu Then
EnableMenuItem ll_SysMenu, SC_NEWMENU, ByVal _
IIf(WindowState = vbMinimized, MF_GREYED, 0)
End If
End If
End Select
WindowProc = CallWindowProc(ml_OldWinProc, hwnd, Msg, wParam, lParam)
End Function
Private Sub SubClass()
'store object refernce so we can check its properties later
SetWindowLong Me.hwnd, GWL_USERDATA, ObjPtr(Me)
ml_OldWinProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf FrmProc)
End Sub
Private Sub UnSubClass()
If ml_OldWinProc Then
Call SetWindowLong(Me.hwnd, GWL_WNDPROC, ml_OldWinProc)
End If
End Sub
Private Sub AddAboutMenu()
Dim ll_OwnerWindowHandle As Long
Dim ll_MenuHandle As Long
ll_OwnerWindowHandle = Me.hwnd
'Get system menu
ll_MenuHandle = GetSystemMenu(ll_OwnerWindowHandle, False)
'Add new menu item
Call AppendMenu(ll_MenuHandle, MF_SEPARATOR, 0&, 0&
'replace the "New Item" below with the text you want to appear on the new
'menu item
Call AppendMenu(ll_MenuHandle, MF_STRING, SC_NEWMENU, "&New Item"
End Sub
Eric De Decker
vbg.be@vbgroup.nl
Licence And Copy Protection AxtiveX
Source CodeBook for the programmer
