Subclassing

Another example is giving status messages when the mouse cursor is over a menu item. This time, windows sends a WM_MENUSELECT message. Make sure your Form is named Form1 and you have a label called lblSel before starting.

'// extra constants and windows api
Public Const MF_BYCOMMAND = &H0&
Public Const MF_BYPOSITION = &H400&
Public Const MF_POPUP = &H10&
Public Const WM_MENUSELECT = &H11F

Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long

Public Function WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
    '// ----WARNING----
    '// do not attempt to debug this procedure!!
    '// ----WARNING----

    '// this is our implementation of the message handling routine
    '// determine which message was recieved
    Select Case iMsg
    Case WM_MENUSELECT
        '// This occurs when the menu is being closed
        If lParam = 0 Then Exit Function
        '// variables
        Dim MenuItemStr As String * 128
        Dim MenuHandle As Integer
        '// Get the low word from wParam: this contains the command ID or position of the menu entry
        MenuHandle = GetLowWord(wParam)
       
        '//If the highlighted menu is the top of a poup menu, pass menu item by position
        If (GetHighWord(wParam) And MF_POPUP) = MF_POPUP Then
           
            '//Get the caption of the menu item
            If GetMenuString(lParam, MenuHandle, MenuItemStr, 127, MF_BYPOSITION) = 0 Then Exit Function
           
        Else '// Otherwise pass it by command ID
           
            '//Get the caption of the menu item
            If GetMenuString(lParam, MenuHandle, MenuItemStr, 127, MF_BYCOMMAND) = 0 Then Exit Function
           
        End If
        '// return item to label to remove any nulls
        Form1.lblSelItem = MenuItemStr
        '// display a message in a label
        Select Case Form1.lblSelItem
        Case "Item 1"
            Form1.lblSelItem = "Adds a Font"
        Case Else
             Form1.lblSelItem = "Item Unknown: " & Form1.lblSelItem
        End Select
    Case Else
        '// pass all messages on to VB and then return the value to windows
        WindowProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)
    End Select
End Function

Public Function GetLowWord(Word As Long)
   GetLowWord = CInt("&H" & Right$(Hex$(Word), 4))
End Function

Public Function GetHighWord(Word As Long)
    GetHighWord = CInt("&H" & Left$(Hex$(Word), 4))
End Function