clsmenubarcontrol.cls

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

            SetTextColor destDC, ConvertVBSysColor(m_fColor(fcDisabled))
        ElseIf m_LastState Then
            fColor = SetTextColor(destDC, ConvertVBSysColor(m_fColor(fcSelected)))
        Else
            fColor = SetTextColor(destDC, ConvertVBSysColor(m_fColor(fcInActive)))
        End If
        If m_HiliteStyle = 0 Then
            If m_HiliteStyle = 0 And ((m_TrackLevel Or 2) = m_TrackLevel) Then OffsetRect dcRect, 1, 1
        End If
        hFont = SelectObject(destDC, m_Font)
        mCaption = GetMenuItemCaption(m_CurSelect)
        DrawText destDC, mCaption, -1, dcRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
        SelectObject destDC, hFont
        SetTextColor destDC, fColor
    End If
    If destDC Then
        If hMnuBmp Then SelectObject m_MenuDC, hMnuBmp
        SelectClipRgn destDC, 0
        ReleaseDC p_Hwnd, destDC
    End If
End If

End Sub

Private Sub DrawHilite(hDC As Long, mRect As RECT, isPushed As Boolean)
Dim bColor1 As Long, bColor2 As Long
Dim xOffset As Long, yOffset As Long
Dim hOldPen As Long, hBrush As Long

If m_HiliteStyle Then
'    If isPushed Then
        hBrush = CreateSolidBrush(ConvertVBSysColor(m_HiliteColor(1)))
        FillRect hDC, mRect, hBrush
        DeleteObject hBrush
'    End If
    hBrush = CreateSolidBrush(ConvertVBSysColor(m_HiliteColor(0)))
    FrameRect hDC, mRect, hBrush
    DeleteObject hBrush
Else
    If isPushed Then
        bColor1 = m_HiliteColor(1)
        bColor2 = m_HiliteColor(0)
'        mRect.Bottom = mRect.Bottom + 1
    Else
        bColor1 = m_HiliteColor(0)
        bColor2 = m_HiliteColor(1)
    End If
    hOldPen = SelectObject(hDC, CreatePen(0, 1, ConvertVBSysColor(bColor1)))
    MoveToEx hDC, mRect.Left, mRect.Bottom, ByVal 0&
    LineTo hDC, mRect.Left, mRect.Top
    LineTo hDC, mRect.Right, mRect.Top
    DeleteObject SelectObject(hDC, CreatePen(0, 1, ConvertVBSysColor(bColor2)))
    LineTo hDC, mRect.Right, mRect.Bottom
    LineTo hDC, mRect.Left - 1, mRect.Bottom
    DeleteObject SelectObject(hDC, hOldPen)
End If
End Sub

Friend Function GetHitTest(X As Long, Y As Long) As Long
' identifies if mouse is over a menubar menu item
Dim itemNr As Long
For itemNr = 0 To UBound(mnuItem)
    If PtInRect(mnuItem(itemNr).mRect, X, Y) Then
        GetHitTest = itemNr + 1 ' append 1 here,it will be remove later
        Exit Function
    End If
Next
End Function

Friend Sub TrackSystemMenu(sysRegion As Long, leftAligned As Boolean)
' displays the system menu
Dim mPts As POINTAPI, sysRect As RECT
Dim X As Long, Y As Long, tpmFlags As Long
    
Const TPM_BOTTOMALIGN As Long = &H20&

If sysRegion = 0 Then
    GetCursorPos mPts
    X = mPts.X: Y = mPts.Y
Else
    GetRgnBox sysRegion, sysRect
    If leftAligned Then
        X = sysRect.Right + 2
        Y = sysRect.Bottom
        tpmFlags = TPM_BOTTOMALIGN
    Else
        X = sysRect.Left
        Y = sysRect.Bottom + 2
    End If
End If
If m_Tracking Then ' called as part of the menu loop
    TrackMenuBar -100, True, True, False, True, X, Y, tpmFlags
Else                ' default display method
    TrackPopupMenu GetSystemMenu(p_Hwnd, 0), tpmFlags, X, Y, 0, p_Hwnd, ByVal 0&
End If
End Sub

Friend Sub TrackMenuBar(ByVal menuPos As Long, ByVal isClicked As Boolean, _
    ByVal hasSysIcon As Boolean, ByVal hiliteOnly As Boolean, _
    Optional bSelectFirst As Boolean, _
    Optional ByVal X As Long, Optional ByVal Y As Long, _
    Optional ByVal pFlags As Long)

' This routine and the next four below are all part of the menu loop
' A bit unique from others out there cause it does handle keyboard
' loops to include the system menu & also handles menubar menu items
' that do not have submenus....

' THE MENU LOOP PART 1 - Showing the appropriate submenu/systemmenu

' Parameters....
' menuPos is the zero-based menubar item position
' isClicked is same as mouse down
' hasSysIcon indicates keybd navigation can go to the system menu in a loop
' hiliteOnly only will not display submenus; otherwise it will
' bSelectFirst will attempt to hilight the 1st menu item in submenu (disabled or not)
' X & Y are optional screen coords to display popup menus
' pFlags are optional and generally used here to redraw/refresh menubar

Dim subID As Long
Dim mnuRect As RECT, wndRect As RECT

If isClicked = True And hiliteOnly = False Then ' user clicked on the submenu item
    If menuPos > -1 Then    ' not the system menu which is either -99 or -100
        ' Test for upper level menus without submenus -- some people do this...
        subID = GetSubMenu(m_Menu, menuPos) ' see if it has a submenu
        If subID = 0 Then                   ' no submenu - fire the event
            TrackingState = False   ' release hooks & refresh menubar
            DrawMenuBarItems 1, 0, mnuRect, wndRect, MNU_Reset, MNU_Refresh
            ' send the click event
            If (mnuItem(menuPos).Flags And MF_DISABLED) <> MF_DISABLED Then _
                PostMessage p_Hwnd, WM_COMMAND, mnuItem(menuPos).ID, ByVal 0&
            HTrack.htk_FromKeyBd = False
            HTrack.htk_ESC = False
            Exit Sub
        End If
    End If
Else
    If isClicked Then
        subID = GetSubMenu(m_Menu, menuPos) ' see if it has a submenu
    Else
        ' special meaning and used internally in this class...only when not displaying items
        If pFlags = MNU_Refresh Or pFlags = MNU_Reset Or pFlags = MNU_Reset * 100 Then
            DrawMenuBarItems 1, 0, mnuRect, wndRect, menuPos, pFlags
            If pFlags = MNU_Reset * 100 Then
                ' special case: user exited menu with escape while submenus were
                ' displayed. Windows generally remains in the loop and this message
                ' will re=enter the loop to mimic that functionality
                TrackingState = False
                PostMessage p_Hwnd, &H112, &HF100&, -menuPos
            End If
            HTrack.htk_FromKeyBd = False
            HTrack.htk_ESC = False
            Exit Sub
        End If
    End If
End If

''Debug.Print "entering menu loop with "; menuPos

' build the hotkey list if needed
If Len(m_HotKeys) = 0 Then BuildHotKeyList

' calc tracking level :: 1=hilite only, 2=auto select submenu
m_TrackLevel = 1 - isClicked
If hasSysIcon Then m_TrackLevel = m_TrackLevel Or 4

Do
    
    m_Tracking = False     ' initially turn of tracking
    If menuPos = -99 Or menuPos = -100 Then ' system menu here
        ' erase any previously highlighted menubar items
        DrawMenuBarItems 1, 0, mnuRect, wndRect, MNU_Reset, 0
    Else    ' menubar item, highlight it
        DrawMenuBarItems 1, 0, mnuRect, wndRect, menuPos, pFlags
        pFlags = 0
    End If
    m_Tracking = True ' set property for subclass wndProc to check
    
    ' regardless whether or not a menu item has a submenu, if we are
    ' on the 1st level of tracking (hilighting only) then don't show submenu
    If (m_TrackLevel Or 1) = m_TrackLevel Then subID = 0
    
    SetProp p_Hwnd, "nextMnuPos", -1    ' set a default "failure" value
    SetInputHook False, Nothing         ' ensure keybd/mouse hook disabled
    
    GetCursorPos HTrack.htk_Pt    ' cache current cursor
    
    If subID > 0 Then   ' menubar item has a submenu - easy
    
        SetMenuHook True, Me    ' sneak a peek on mouse movements
        
        ' show the menubar submenu & select 1st item if appropriate
        If bSelectFirst Then
            PostMessage p_Hwnd, &H100&, vbKeyDown, ByVal 0&
            bSelectFirst = False
        End If
        TrackPopupMenu subID, pFlags, _
            m_MBarXY.X + mnuItem(menuPos).mRect.Left, _
            m_MBarXY.Y + mnuItem(menuPos).mRect.Bottom, 0, p_Hwnd, ByVal 0&
        
        SetMenuHook False, Nothing  ' disable menu hook
        ' get the next menu to display set in routine: SetMenuAction
        menuPos = GetProp(p_Hwnd, "nextMnuPos")
        m_Tracking = False ' reset variable
        
    ElseIf menuPos = -99 Then   ' keyboard left/right to system menu
        ' forward message back so routines can prevent VB's min/max/close drawing
        PostMessage p_Hwnd, &H313, &HF100&, ByVal 0&
        menuPos = -1    ' prevent looping; the above postmessage will get back here
        
    ElseIf menuPos = -100 Then  ' sysmenu is back and ready to display
        
        SetMenuHook True, Me    ' sneak a peek on mouse movements
        
        ' show the system menu with optional X,Y & alignment flags
        ' and also auto-select the 1st menu item
        PostMessage p_Hwnd, &H100&, vbKeyDown, ByVal 0&
        TrackPopupMenu GetSystemMenu(p_Hwnd, 0), pFlags, X, Y, 0, p_Hwnd, ByVal 0&
        
        menuPos = GetProp(p_Hwnd, "nextMnuPos") ' get next menu to display
        pFlags = 0      ' reset if ever used
        m_Tracking = False ' reset flag
        
    Else ' main menu item without submenus, or tracking in hilight mode only
         ' We'll need to track via mouse & keyboard hooks
        menuPos = -1            ' prevent looping for now
        m_Tracking = True ' set flag
        SetInputHook True, Me   ' start the keybd/mouse hooks
    End If
    
    HTrack.htk_FromKeyBd = False  ' flag to indicate menu navigated via keyboard
    If menuPos = -1 Then   ' is there a next menu to display?
        Exit Do ' no next menu or hilight tracking only; boogy out
    Else
        subID = 0           ' reset variables
        With HTrack         ' this is used to help navigate popups
            .htk_Was = 0    ' with keyboard and mouse simultaneously
            .htk_Now = 0
            .htk_Next = 0
            .htk_ESC = False        'flag to indicate ESC last pressed or not
        End With
        ' now see if the next menu item has a submenu or not
        If menuPos > -1 Then subID = GetSubMenu(m_Menu, menuPos)
        ' return back up to the loop
    End If
Loop
''Debug.Print "exiting menu loop"
End Sub

Friend Function SetMenuAction(lParam As Long) As Boolean

' THE MENU LOOP PART 2 - Normal popups including system menu

' This routine is the callback function from the MessageHook &
' is used only for menubar items with submenus.

''Debug.Print " getting menu messages "

If lParam = 0 Or m_Tracking = False Then Exit Function

Dim newMsg As MSG
Dim newMenuID As Long

' copy the message so we can look at it
CopyMemory newMsg, ByVal lParam, Len(newMsg)


With newMsg
    Select Case .message    ' these are common WM_flags
    Case WM_MOUSEMOVE
        ' ensure the point is somewhere in our window!
        If WindowFromPoint(.pt.X, .pt.Y) = p_Hwnd Then
            ' each popup usually is followed by 1 or more mouse moves
            ' Since we cached the current coords, we can prevent misfiring
            ' when cursor is over one item, but user keyboards to another
            ' and when it opens, the mouse move message would trigger the
            ' routines to go back to the item where the cursor is. Annoying.
            If HTrack.htk_Pt.X <> .pt.X Or HTrack.htk_Pt.Y <> .pt.Y Then
                ' ok, a new spot, get a hit test on menuitems
                newMenuID = GetHitTest(.pt.X - m_MBarXY.X, .pt.Y - m_MBarXY.Y) - 1
                ' ensure not already highlighted and is enabled...
                If newMenuID <> m_CurSelect And newMenuID > -1 Then
                    ' set flag & post cancel message will will then
                    ' release the loop so it can continue
                    SetProp p_Hwnd, "nextMnuPos", newMenuID
                    PostMessage p_Hwnd, WM_CANCELMODE, 0, ByVal 0&
                End If
            End If
        End If
    Case WM_KEYDOWN ' keyboard navigation
        HTrack.htk_ESC = False  ' indicate last key pressed is not the ESC key
        ' when navigated from submenu-less item to here, the right or left
        ' Key_Down message will follow unfortunately. So we use the
        ' HTTrack.htk_FromKeyBd set in that routine to warn us here.
        ' For description of other HTTrack elements, see further below.
        Select Case .wParam     ' virtual key codes
        Case vbKeyLeft
            If (HTrack.htk_Now = HTrack.htk_Was Or HTrack.htk_Was = 0) _
                And HTrack.htk_FromKeyBd = False Then
                ' set flag to next menu item, send cnx message to loop
                SetProp p_Hwnd, "nextMnuPos", NextMenuPosition(True, True)
                PostMessage p_Hwnd, WM_CANCELMODE, 0, ByVal 0&
                SetMenuAction = True    ' eat this message
            Else
                HTrack.htk_FromKeyBd = False    ' reset flag
            End If
        Case vbKeyRight
            If HTrack.htk_Next = 0 And HTrack.htk_FromKeyBd = False Then
                'set flag to next menu item, send cnx message to loop
                SetProp p_Hwnd, "nextMnuPos", NextMenuPosition(False, True)
                PostMessage p_Hwnd, WM_CANCELMODE, 0, ByVal 0&
                SetMenuAction = True    ' eat this message
            Else
                HTrack.htk_FromKeyBd = False    ' reset flag
            End If
        Case vbKeyReturn
            If (HTrack.htk_Now = 0 Or HTrack.htk_FromKeyBd = True) Then
                HTrack.htk_FromKeyBd = False
                SetMenuAction = True
            End If
        Case vbKeyEscape
            HTrack.htk_ESC = True   ' identify as last key pressed
        End Select
    
    Case &H11F  ' wm_menuselect
        If HiWord(.wParam) = -1 And .lParam = 0 Then ' menu is closing
            If m_CurSelect < 0 Then ' system menu