Add New Menu Item To The Form's Sytem Menu

The system menu is the default pop up menu (with Restore, Move, Minimize, Maximize, etc.) that pops up when you right clicking on the title bar, or when you right clicking on the task bar.

Note: to perform this task, the code below uses subclassing. that's mean that if you won't close your program properly, it may cause your Visual Basic Environment to crash.
You can close your program by pressing Alt +F4, clicking the form X button, or any other way, but don't close the program by pressing the Visual Basic Stop button.

Module Code

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
Go Back