ExtendMenuPp

Option Explicit
Dim MenuItemID As Long
Dim MenuHandle As Long
Dim MenuCloseID As Long
Dim Checked As Boolean
Public OldProc 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
Public Const GWL_WNDPROC = (-4)
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
'The window message to monitor

Const WM_SYSCOMMAND = &H112
'menu API's

Declare Function GetSubMenu Lib "user32" (ByVal hMenu _
As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu _
As Long, ByVal nPos As Long) As Long
Declare Function GetSystemMenu Lib "user32" (ByVal Hwnd _
As Long, ByVal bRevert As Long) As Long
Declare Function AppendMenu Lib "user32" _
Alias "AppendMenuA" (ByVal hMenu As Long, _
ByVal wFlags As Long, ByVal wIDNewItem As Long, _
ByVal lpNewItem As Any) As Long
Declare Function DrawMenuBar Lib "user32" _
(ByVal Hwnd As Long) As Long
Declare Function CheckMenuItem Lib "user32" _
(ByVal hMenu As Long, _
ByVal wIDCheckItem As Long, _
ByVal wCheck As Long) As Long
Public Const MF_SEPARATOR = &H800&
Public Const MF_CHECKED = &H8&
Public Const MF_UNCHECKED = &H0&
'Window Positioning API

Declare Function SetWindowPos Lib "user32.dll" _
(ByVal Hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
'Used to set window to always be on top or not

Const HWND_NOTOPMOST = -2
Const HWND_TOPMOST = -1
Public Function WndProc(ByVal Hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim retval As Long
'Is triggered if Always on top is clicked.

If wMsg = WM_SYSCOMMAND And wParam = MenuItemID Then
WndProc = 0
If Checked Then
'switch menu to unchecked

retval = CheckMenuItem(MenuHandle, MenuItemID,_
MF_UNCHECKED)
'set window to not top most window

retval = SetWindowPos(Hwnd, HWND_NOTOPMOST, 0, 0, 1, 1, _
SWP_NOMOVE Or SWP_NOSIZE)
'toggle checked

Checked = Not Checked
Else
'switch menu to checked

retval = CheckMenuItem(MenuHandle, MenuItemID, MF_CHECKED)
'make window always on top

retval = SetWindowPos(Hwnd, HWND_TOPMOST, 0, 0, 1, 1, _
SWP_NOMOVE Or SWP_NOSIZE)
'toggle checked

Checked = Not Checked
End If
Exit Function
End If
'Is Triggered if Close is clicked.

If wMsg = WM_SYSCOMMAND And wParam = MenuCloseID Then
retval = MsgBox("Are you sure you wish To exit?", _
vbYesNo, "Confirm Close")
If retval = vbNo Then
'Traps out the Close event so window does not close.

WndProc = 0
Exit Function
End If
End If

'Pass on all the other unhandled messages

WndProc = CallWindowProc(OldProc, Hwnd, wMsg, wParam, lParam)
End Function

Public Sub AddMenuItem(Hwnd As Long)
Dim x As Long
Checked = False

'Get system menu handle

MenuHandle = GetSystemMenu(Hwnd, False)

'Append a seporator line

x = AppendMenu(MenuHandle, MF_SEPARATOR, 0, "")

'Append Always on Top Item, and Set to

'unchecked - 555 is the ItemID.

x = AppendMenu(MenuHandle, MF_UNCHECKED, 555, "Always On Top")

'Redraw the menubar

x = DrawMenuBar(Hwnd)

'Get menuitemid for item 8 and 6 in system menu which are

'Always on Top' and 'Close'.

MenuItemID = GetMenuItemID(MenuHandle, 8)
MenuCloseID = GetMenuItemID(MenuHandle, 6)

'store the old message handler.

OldProc = GetWindowLong(Hwnd, GWL_WNDPROC)

'set the message handler to ours.

SetWindowLong Hwnd, GWL_WNDPROC, AddressOf WndProc

End Sub

Sub UnHookWindow(Hwnd As Long)
'Sets procedure for handling events backto the original.

SetWindowLong Hwnd, GWL_WNDPROC, OldProc
End Sub

'**** FORM LEVEL CODE ****

Option Explicit
Private Sub Form_Load()
'Setup menus and message handlers.

Call AddMenuItem(Me.Hwnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
'Restore message handler. Run this or crash.

Call UnHookWindow(Me.Hwnd)
End Sub