clsmenubarcontrol.cls

AeroSuite--一组非常漂亮的VISTA控件集

                ' if no other menu items exist then exit loop completely
                HTrack.htk_Now = NextMenuPosition(False, False)
                If HTrack.htk_Now < 0 Then HTrack.htk_ESC = False
            Else
                HTrack.htk_Now = m_CurSelect ' cache current item
            End If
            TrackingState = False           ' reset tracking variables
            If HTrack.htk_ESC Then          ' last key pressed was an ESC
                ' no need to check tracking level 'cause this routine is
                ' only called when tracking level = 2. So we go back to
                ' tracking level one...
                SendMessage p_Hwnd, WM_CANCELMODE, 0, ByVal 0&
                TrackMenuBar HTrack.htk_Now, False, False, False, , , , MNU_Reset * 100
                SetMenuAction = True
            Else    ' some other key or mouse stroke, loss of focus, etc
                    ' caused menu to close; completely exit menu loop
                TrackMenuBar 0, False, False, False, , , , MNU_Refresh
            End If
        Else    ' got a selection; track a few things...
            ' If this menu item as a submenu, we can let O/S handle
            ' right arrow message; otherwise, we move to next menubar item
            HTrack.htk_Next = ((HiWord(.wParam) And &H10&) = &H10&) 'GetSubMenu(.lParam, LoWord(.wParam))
            ' get current submenu handle this item belongs to
            ' It will help to determine whether the left arrow can be
            ' handled by O/S or we move to previous menubar item
            HTrack.htk_Now = .lParam
            ' Set a point where menu can no longer go back using left
            ' arrows, regardless how deep the submenus go which would
            ' change the .htk_Next & .htk_Now values
            If HTrack.htk_Was = 0 Then HTrack.htk_Was = .lParam
            With HTrack
                'Debug.Print .htk_Was; .htk_Now; .htk_Next;
            End With
            'Debug.Print .wParam; ((HiWord(.wParam) And &H8000&) = &H8000&)
        End If
    Case WM_LBUTTONDOWN ' clicking...
        HTrack.htk_ESC = False
        ' get a current hit test
        newMenuID = GetHitTest(.pt.X - m_MBarXY.X, .pt.Y - m_MBarXY.Y) - 1
        If newMenuID < 0 Then
            TrackMenuBar 0, False, False, False, , , , MNU_Refresh
        ElseIf newMenuID = m_CurSelect Then ' clicking on current item
            ' cancel the popup
            TrackMenuBar newMenuID, True, ((m_TrackLevel Or 4) = m_TrackLevel), True, , , , MNU_Refresh
            PostMessage p_Hwnd, WM_CANCELMODE, 0, ByVal 0&
            SetMenuAction = True    ' eat this one
        Else    ' clicking on a menu item most likely
            TrackMenuBar 0, False, False, False, , , , MNU_Refresh
        End If
    Case Else
'        'Debug.Print "menu hook msg"; .message; .wParam; .lParam
    End Select
End With
End Function


Friend Function SetMouseAction(wParam As Long, lParam As Long) As Boolean

If m_Tracking = False Then Exit Function

' THE MENU LOOP PART 3 - Menubar items without submenus (Mouse Hook)
' We are manually tracking the menubar at this point...

' This routine is the callback function from the Mouse Hook &
' is used only for menubar items without submenus.

' hittest of 30 is a custom value I forced on windows whenever a
' mouse rode over a menubar item....

''Debug.Print wMsg; wHitTest; menuItem


Dim mPt As POINTAPI, menuItem As Long
Select Case wParam
    Case WM_LBUTTONDOWN, &HA1, WM_NCRBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN, WM_XBUTTONDOWN
        TrackingState = False
        TrackMenuBar 0, False, False, False, , , , MNU_Refresh
        m_TrackLevel = 0
    Case WM_LBUTTONUP, WM_NCLBUTTONUP
        GetCursorPos mPt
        menuItem = GetHitTest(mPt.X - m_MBarXY.X, mPt.Y - m_MBarXY.Y) - 1
        If menuItem < 0 Then
            TrackingState = False
            TrackMenuBar 0, False, False, False, , , , MNU_Refresh
        Else
            TrackMenuBar menuItem, True, False, False
        End If
        SetMouseAction = True
    Case Else
        Dim inMsg As MOUSEHOOKSTRUCT
        CopyMemory inMsg, ByVal lParam, Len(inMsg)
        If inMsg.hWnd = p_Hwnd Then
            With inMsg
                If .wHitTestCode = 30 Then
                    SetMouseAction = True
                    GetCursorPos mPt
                    Select Case wParam
                        Case &HA0 'WM_NCMOUSEMOVE
                            If (HTrack.htk_Pt.X <> mPt.X Or HTrack.htk_Pt.Y <> mPt.Y) Then
                                ' get current hittest to a specific item
                                menuItem = GetHitTest(mPt.X - m_MBarXY.X, mPt.Y - m_MBarXY.Y) - 1
                                If menuItem < 0 Then Exit Function
                                If menuItem <> m_CurSelect And menuItem > -1 Then
                                    ' ok, not the same item
                                    ' tell message loop to restart with this menuitem
                                    TrackMenuBar menuItem, ((m_TrackLevel Or 2) = m_TrackLevel), ((m_TrackLevel Or 4) = m_TrackLevel), (GetSubMenu(m_Menu, menuItem) = 0)
                                End If
                            End If
                        Case Else
                    End Select
                End If
            End With
        End If
End Select

End Function

Friend Function SetKeyBdAction(wKeyCode As Long, lParam As Long) As Boolean

If m_Tracking = False Then
    'Debug.Print "entering keyboard hook "; m_Tracking
    TrackingState = False
    SetKeyBdAction = True
    Exit Function
End If
' THE MENU LOOP PART 4 - Menubar items without submenus (Keyboard Hook)
' We are manually tracking the menubar at this point...

' This routine is the callback function from the Keyboard Hook &
' is used only for menubar items without submenus.

Dim bKeyUp As Boolean, bShowMenuItem As Boolean, bHasSubMenu As Boolean
Dim newMenuPos As Long, tgtKey As String * 1

bKeyUp = ((lParam And &H80000000) = &H80000000)

If Not bKeyUp Then

    Select Case wKeyCode
    
    Case vbKeyF10, vbKeyMenu    ' second alt keydown; end menu loop
        TrackingState = False
        TrackMenuBar 0, False, False, False, , , , MNU_Refresh
    
    Case vbKeyEscape    ' not much to do here; just removehooks
        TrackingState = False
        TrackMenuBar 0, False, False, False, , , , MNU_Refresh
    
    Case vbKeyUp, vbKeyDown, vbKeyReturn ' no action on submenu-less items
        If GetSubMenu(m_Menu, m_CurSelect) Then
            HTrack.htk_FromKeyBd = (wKeyCode = vbKeyReturn)
            TrackMenuBar m_CurSelect, True, ((m_TrackLevel Or 4) = m_TrackLevel), False, (wKeyCode = vbKeyReturn), , , MNU_Reset
        ElseIf wKeyCode = vbKeyReturn Then
            TrackingState = False
            TrackMenuBar m_CurSelect, True, False, False
        End If

    Case vbKeySpace     ' if a sysicon then show it
        If (m_TrackLevel Or 4) = m_TrackLevel Then TrackMenuBar -99, True, True, False
        
    Case vbKeyLeft, vbKeyRight ' navigating at menubar
        ' get the next valid menu position
        newMenuPos = NextMenuPosition((vbKeyLeft = wKeyCode), ((m_TrackLevel Or 2) = m_TrackLevel))
        If newMenuPos > -1 Then ' got another menubar item...
            bShowMenuItem = True
            HTrack.htk_FromKeyBd = True
        ElseIf newMenuPos = -99 Then        ' got to the system menu
            m_Tracking = False
            HTrack.htk_FromKeyBd = True
            TrackMenuBar newMenuPos, True, True, False
        Else ' there isn't any other items; just 1 menu bar item
            If m_CurSelect = MNU_Reset Then ' system menu
                ' Windows keep user in menu loop;
                ' let's just exit out since user cannot really tell
                m_Tracking = False
                TrackMenuBar 0, False, False, False, , , , MNU_Reset
            End If
        End If
    Case Else ' accelerator key? let's check
        Dim bHasDups As Boolean, dupMenuPos As Long
        tgtKey = LCase(Chr$(wKeyCode))
        newMenuPos = InStr(m_HotKeys, tgtKey) - 1
        If newMenuPos > -1 Then
            If (InStr(newMenuPos + 2, m_HotKeys, tgtKey) > 0) Then
                ' we have more than one hotkey like this one!
                ' 1st see if we are currently on that one?
                If Mid$(m_HotKeys, m_CurSelect + 1, 1) = tgtKey Then
                    ' currently on a dup key, let's find next one
                    dupMenuPos = InStr(m_CurSelect + 2, m_HotKeys, tgtKey)
                    If dupMenuPos > 0 Then newMenuPos = dupMenuPos - 1
                End If
            End If
            bShowMenuItem = True
            HTrack.htk_FromKeyBd = False
        Else
            TrackingState = False
            TrackMenuBar 0, False, False, False, , , , MNU_Refresh
            If wKeyCode <> vbKeyTab Then
                Beep
                'Debug.Print "beep beep beep beep" 'cute? some testing done on PC w/o speakers
            End If
        End If
    End Select
    If bShowMenuItem Then
        m_Tracking = False ' reset flag
        bHasSubMenu = (GetSubMenu(m_Menu, newMenuPos) <> 0)
        If ((m_TrackLevel Or 1) = m_TrackLevel) Then HTrack.htk_FromKeyBd = False
        TrackMenuBar newMenuPos, ((m_TrackLevel Or 2) = m_TrackLevel), ((m_TrackLevel Or 4) = m_TrackLevel), Not bHasSubMenu, bHasSubMenu
    End If
End If
SetKeyBdAction = True
End Function

Friend Function TraceHotKey(wKeyCode As Long, hasSysIcon As Boolean, isSysCommand As Boolean) As Long

Dim mnuPos As Long, tgtKey As String * 1
Dim lRtnVal As Long

Const MNC_CLOSE As Long = 1
Const MNC_EXECUTE As Long = 2
Const MNC_IGNORE As Long = 0
Const MNC_SELECT As Long = 3

If Len(m_HotKeys) = 0 Then BuildHotKeyList
tgtKey = LCase(Chr$(wKeyCode))
mnuPos = InStr(m_HotKeys, tgtKey) - 1


' send a bad menu execute command for a valid menu item
' otherwise system will beep
lRtnVal = MakeDWord(-1, MNC_EXECUTE)

If mnuPos < 0 Then
    If isSysCommand Then
        Beep
        'Debug.Print "beep beep beep beep" 'cute? some testing done on PC w/o speakers
    Else
        lRtnVal = 0 ' system will beep for us
    End If
    ' beep manually if sent via wm_syscommand; otherwise wm_menuchar will beep for us
Else
    If isSysCommand = False And m_Tracking = True Then
        If InStr(m_HotKeys, tgtKey) = 0 Then lRtnVal = 0
    Else
        If InStr(mnuPos + 2, m_HotKeys, tgtKey) Then
            ' have more than one menu item with this hot key
            TrackMenuBar mnuPos, False, hasSysIcon, True
        Else
            If GetSubMenu(m_Menu, mnuPos) = 0 Then ' submenuless-menubar item
                ' simply call routine to execute the item
                TrackMenuBar mnuPos, True, False, False
            Else                                    ' has submenu
                If isSysCommand Then
                    ' display the submenu
                    TrackMenuBar mnuPos, True, hasSysIcon, False, True
                Else    ' received via wm_menuchar message, this message
                        ' will close the menu immediately since it no
                        ' longer exists via SetMenu commands. So we will
                        ' post a new message to activate it
                    lRtnVal = MakeDWord(mnuPos + 0, MNC_CLOSE)
                    PostMessage p_Hwnd, &H112, &HF100&, ByVal wKeyCode
                End If
            End If
        End If
    End If
End If
TraceHotKey = lRtnVal
End Function

Private Sub BuildHotKeyList()

Dim I As Integer, mnuCaption As String
Dim ampPos As Integer, lastPos As Integer, sList As String

For I = 0 To MenuItemCount(0) - 1
    ampPos = 0
    mnuCaption = LCase$(GetMenuItemCaption(I + 0, 0, 0)) & Chr$(0)
    lastPos = Len(mnuCaption)
    ampPos = InStr(ampPos + 1, mnuCaption, "&")
    Do While ampPos
        If ampPos Then
            If Mid$(mnuCaption, ampPos + 1, 1) = "&" Then
                ampPos = ampPos + 1
            Else
                lastPos = ampPos + 1
            End If
        End If
        ampPos = InStr(ampPos + 1, mnuCaption, "&")
    Loop
    If lastPos = Len(mnuCaption) Or ((mnuItem(I).Flags Or MF_DISABLED) = mnuItem(I).Flags) Then
        sList = sList & Chr$(0)
    Else
        sList = sList & Mid$(mnuCaption, lastPos, 1)
    End If
Next
m_HotKeys = sList
'Debug.Print "hot key list is >"; sList; "<"
End Sub

Private Function NextMenuPosition(bLeft As Boolean, includeSysMenu As Boolean) As Long

' Routine finds the next available menubar item, including system menu
' Although currently used only for keyboard navigation;
' includeSysMenu paramater is included to test vertically for
' owner-drawn menus when the time comes

Dim newPos As Long

If m_CurSelect = MNU_Reset Then ' on the system menu, not menubar
    ' move to the first or last item on menubar depending on direction
    If MenuItemCount(0) Then
        newPos = UBound(mnuItem) * Abs(bLeft = True)
        HTrack.htk_FromKeyBd = True
    Else
        newPos = -1
    End If
Else            ' on the menubar, goto 1 previous or 1 next
    If bLeft Then newPos = m_CurSelect - 1 Else newPos = m_CurSelect + 1
    If newPos < 0 Then
        If includeSysMenu Then newPos = -99 Else newPos = UBound(mnuItem)
    ElseIf newPos > UBound(mnuItem) Then
        If includeSysMenu Then newPos = -99 Else newPos = 0
    End If
End If
NextMenuPosition = newPos   ' return the next value
End Function