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

Subclassing is used To trap when the 'Always on Top' item
is clicked. The custom message handler uses the SetWindowPos
Function to keep window on top or reset it to normal.
Also On a lark I traped out the close menu item To prompt
before closing. If you say yes Then the close message it
passed otherwise the close message is traped out and the form
stays open.

Side Effects:'Be careful and save work
often. Subclassing can cause your system to GPF.