clsmenubarcontrol.cls

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

    SetMenu p_Hwnd, 0
    DrawMenuBar p_Hwnd
'    ForceMenuBarRepaint
'    Stop
End If

End Property

Public Property Let MenubarStatic(isStatic As Boolean)
m_mbarLocked = isStatic
End Property
Public Property Get MenubarStatic() As Boolean
MenubarStatic = m_mbarLocked
End Property

Friend Property Let ParentWIndow(hWnd As Long)
p_Hwnd = hWnd

Dim hMenu As Long
hMenu = GetMenu(p_Hwnd)
If hMenu Then m_Menu = hMenu
End Property

Private Property Get MenuItemCount(hSubMenu As Long) As Long
If m_Menu Then
    If hSubMenu Then
        MenuItemCount = GetMenuItemCount(hSubMenu)
    Else
        MenuItemCount = GetMenuItemCount(m_Menu)
    End If
End If
End Property

Public Property Let ReleaseRefreshLock(bRelease As Boolean)
m_LastState = -2
End Property

Public Function HiliteStyle(bSet As Boolean, isFlat As Boolean) As Boolean
If bSet Then
    m_HiliteStyle = Abs(isFlat)
Else
    HiliteStyle = (m_HiliteStyle = 1)
End If
    
End Function

Public Sub HiliteColors(Color1 As Long, Color2 As Long)
m_HiliteColor(0) = Color1
m_HiliteColor(1) = Color2
End Sub

Public Sub ForceMenuBarRepaint()
m_LastState = -2
RaiseEvent RefreshMenuBar
End Sub

Friend Sub DrawMenuBarBkg(hDC As Long, destDC As Long, mbarRight As Long, mBarHeight As Long, isActive As Boolean)
Dim bSizeChanged As Boolean, bUserDrawn As Boolean
Dim deskDC As Long, hOldBmp As Long, hNewBmp As Long

    ' ensure bitmap is the right size
    hOldBmp = ResizeBitmap(destDC, m_dcBitmap, mbarRight, mBarHeight, hDC, bSizeChanged)
    If bSizeChanged Or CLng(isActive) <> m_LastState Then
        m_LastState = CLng(isActive)
        hNewBmp = ResizeBitmap(destDC, m_bmpMenuBar, mbarRight, mBarHeight, m_MenuDC, False)
        Dim callBack As CustomWindowCalls
        If GetObjectFromPointer(GetProp(p_Hwnd, "lvImpCB_Ptr"), callBack) Then
            Call callBack.UserDrawnMenuBar(hDC, mbarRight, mBarHeight, isActive, bUserDrawn)
        End If
        If Not bUserDrawn Then
            Dim hBrush As Long, dcRect As RECT
            SetRect dcRect, 0, 0, mbarRight, mBarHeight
            hBrush = CreateSolidBrush(ConvertVBSysColor(vbButtonFace))
            FillRect hDC, dcRect, hBrush
            DeleteObject hBrush
        End If
        BitBlt m_MenuDC, 0, 0, mbarRight, mBarHeight, hDC, 0, 0, vbSrcCopy
    Else
        hNewBmp = SelectObject(m_MenuDC, m_bmpMenuBar)
    End If
    BitBlt hDC, 0, 0, mbarRight, mBarHeight, m_MenuDC, 0, 0, vbSrcCopy
    SelectObject m_MenuDC, hNewBmp
    SelectObject hDC, hOldBmp

End Sub

Friend Sub GetBarDimensions(hDC As Long, mBarWidth As Long, mBarHeight As Long, xLeft As Long, yTop As Long)

' gotta be a faster way, but can't think of one.
' Unless a skinned window has a fixed menubar dimension, in order
' to measure the menubar, we have to re-measure each menubar item.
' Measuring the menubar is triggered by window sizing, some
' window style changes, and changing a menu item's properties....
' This is understandable and can be easily
' trapped/identified. However, whenever DrawMenuBar is called,
' windows is sent a message that makes it appear the window resized.
' Do we ignore it? No, cause maybe a menu item was added/deleted or
' possibly the caption changed which causes menubar wrap. Open to
' suggestions; thankfully menu items on a menubar don't number in
' the dozens!  Caching the captions doesn't appear to be a way to
' measure quicker since you need to check each menu caption anyway
' and then do an IF to see if it changed or IF the properties changed.

' cache for use elsewhere. This the menubar left/top in window coords
m_MBarXY.X = xLeft
m_MBarXY.Y = yTop

If hDC = 0 Then Exit Sub

Dim nrItems As Long, deskDC As Long
Dim hOldBmp As Long, hNewBmp As Long
Dim bSizeChanged As Boolean, bUserDrawn As Boolean


m_HotKeys = ""  ' reset so it can be built on demand if needed
nrItems = MenuItemCount(0)

If nrItems Then
    
    If m_Font = 0 Then Set Font = Nothing
    
    
    If m_mbarLocked = False Then
            
        Dim itemNr As Long, hOldFont As Long
        Dim iRect As RECT, mnuCaption As String
        Dim lState As Long, mnuID As Long
        Const lineSpacer As Integer = 12
        
        
        ReDim Preserve mnuItem(0 To nrItems - 1)
        hOldFont = SelectObject(m_MenuDC, m_Font)
        
        On Error Resume Next
        
        For itemNr = 0 To nrItems - 1
            mnuCaption = GetMenuItemCaption(itemNr, mnuItem(itemNr).Flags, mnuItem(itemNr).ID)
            iRect.Left = iRect.Right
            DrawText m_MenuDC, mnuCaption, -1, iRect, DT_SINGLELINE Or DT_LEFT Or DT_CALCRECT
            iRect.Right = iRect.Right + lineSpacer
            If iRect.Right >= mBarWidth And iRect.Left > 0 Then
                OffsetRect iRect, -iRect.Left, -iRect.Top + iRect.Bottom + lineSpacer \ 2
            End If
            SetRect mnuItem(itemNr).mRect, iRect.Left, iRect.Top, iRect.Right, iRect.Bottom + lineSpacer \ 2
        Next
        SelectObject m_MenuDC, hOldFont
        mBarHeight = mnuItem(nrItems - 1).mRect.Bottom

        
'            'Debug.Print "recalculated menubar dimensions"
    End If
    
    
Else
    mBarHeight = 0
End If
End Sub

Private Function GetMenuItemCaption(itemPos As Long, Optional fState As Long, Optional fID As Long) As String
Dim MIS As MENUITEMINFO_String
' annotation needed:  menu captions max length of 128 characters
MIS.dwTypeData = String$(128, 0)
MIS.fMask = MIIM_ID Or MIIM_STATE Or MIIM_STRING
MIS.cbSize = LenB(MIS)
MIS.cch = 128 + 1
GetMenuItemInfo_String m_Menu, itemPos, True, MIS
''Debug.Print vbTab; "cch is "; MIS.cch; MIS.wID
If MIS.cch > 0 Then
'    'Debug.Print vbTab; Left$(MIS.dwTypeData, MIS.cch)
    GetMenuItemCaption = Left$(MIS.dwTypeData, MIS.cch)
End If
fID = MIS.wID
fState = MIS.fState
''Debug.Print MIS.wID, MIS.fType
End Function

Friend Sub DrawMenuBarItems(hDC As Long, destDC As Long, _
    menuRect As RECT, windowRect As RECT, _
    ByVal itemSelect As Long, ByVal RefreshFlag As Long)

If m_Font = 0 Or hDC = 0 Then Exit Sub
'Exit Sub

'RaiseEvent MenuBoundary(hDC, xOffset, yOffset, farRight)

''Debug.Print "drawing menu items"
If MenuItemCount(0) = 0 Then Exit Sub

Dim nrItems As Long, itemNr As Long
Dim dcRect As RECT, mBar As RECT, tRect As RECT
Dim hOldBmp As Long, hMnuBmp As Long
Dim hFont As Long, bSwapColor As Boolean, fColor As Long
Dim mCaption As String, clipRgn As Long


If menuRect.Right = menuRect.Left Then ' null rectangle passed
    SetRect menuRect, m_MBarXY.X, m_MBarXY.Y, m_MBarXY.X, m_MBarXY.Y
Else
    m_MBarXY.X = menuRect.Left
    m_MBarXY.Y = menuRect.Top
End If
If windowRect.Right = windowRect.Left Then ' null window rect passed
    GetWindowRect p_Hwnd, windowRect
End If

' convert menubar from screen coords to nonclient coords
mBar = menuRect
OffsetRect mBar, -windowRect.Left, -windowRect.Top

If itemSelect = MNU_ResetAll Then
    m_CurSelect = MNU_Reset     ' reset to no previous selection
    nrItems = UBound(mnuItem)
    itemNr = 0
    ' select cached bitmap and target bitmap
    hOldBmp = SelectObject(hDC, m_dcBitmap)
    hMnuBmp = SelectObject(m_MenuDC, m_bmpMenuBar)
    ' refresh target bitmap vs redrawing all over again
    BitBlt hDC, 0, 0, dcRect.Right, dcRect.Bottom, m_MenuDC, 0, 0, vbSrcCopy
    SelectObject m_MenuDC, hMnuBmp
    ' select the working menu font into DC
    hFont = SelectObject(hDC, m_Font)
    If m_LastState Then ' active titlebar
        fColor = ConvertVBSysColor(m_fColor(fcEnabled))
    Else
        fColor = ConvertVBSysColor(m_fColor(fcInActive))
    End If
    SetTextColor hDC, fColor
    
    ' create an offset for copying from target bitmap to window DC
    dcRect = mBar   ' copy that rectangle & offset to 0,0 for DC drawing
    OffsetRect dcRect, -mBar.Left, -mBar.Top

    For itemNr = 0 To nrItems
        With mnuItem(itemNr)
            ' todo: finish idea here.... for skinning and having a fixed menubar dimension
'            If .mRect.Right > dcRect.Right And m_mbarLocked = True Then Exit For
            ' move menuitem rectangle to window coordinates
            tRect = .mRect
        End With
        ' shift menu rectangle to window DC coords
        OffsetRect tRect, dcRect.Left, dcRect.Top
        ' get caption & print to DC
        mCaption = GetMenuItemCaption(itemNr)
        If ((mnuItem(itemNr).Flags And MF_DISABLED) = MF_DISABLED) And m_LastState <> 0 Then
            SetTextColor hDC, ConvertVBSysColor(m_fColor(fcDisabled))
            bSwapColor = True
        End If
        DrawText hDC, mCaption, -1, tRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
        If bSwapColor Then
            SetTextColor hDC, fColor
            bSwapColor = False
        End If
    Next

    ' draw finished menubar onto the window
    BitBlt destDC, mBar.Left, mBar.Top, dcRect.Right, dcRect.Bottom, hDC, 0, 0, vbSrcCopy
    ' replaced font & original bitmap
    SelectObject hDC, hOldBmp
    SelectObject hDC, hFont
    m_TrackLevel = 0
    m_Tracking = False
    
Else    ' updating menubar due to keyboard/mouse navigation
    If m_Tracking Then Exit Sub
    
    If RefreshFlag = MNU_Refresh Or RefreshFlag = MNU_Reset * 100 Then
        Dim mPt As POINTAPI
        GetCursorPos mPt
        itemSelect = GetHitTest(mPt.X - m_MBarXY.X, mPt.Y - m_MBarXY.Y) - 1
        m_TrackLevel = 0
        RefreshFlag = MNU_Refresh
    Else
        If m_CurSelect = MNU_Reset And itemSelect = MNU_Reset Then Exit Sub
    End If
    
    RaiseEvent GetWindowRegion(clipRgn)
    If m_CurSelect <> itemSelect Or RefreshFlag <> 0 Then
        If m_CurSelect > -1 Then
            ' no repeating selection or removing any hilighted item
            ' setup DC and select appropriate bitmap/font
            destDC = GetWindowDC(p_Hwnd)
            SelectClipRgn destDC, clipRgn
            SetBkMode destDC, 3
            hFont = SelectObject(destDC, m_Font)
            hMnuBmp = SelectObject(m_MenuDC, m_bmpMenuBar)
            ' shift rect to dc coords
            dcRect = mnuItem(m_CurSelect).mRect
            OffsetRect dcRect, mBar.Left, mBar.Top
            With mnuItem(m_CurSelect).mRect
                ' get caption & print to DC
                mCaption = GetMenuItemCaption(m_CurSelect)
                If (mnuItem(m_CurSelect).Flags And MF_DISABLED) = MF_DISABLED Then
                    fColor = SetTextColor(destDC, ConvertVBSysColor(m_fColor(fcDisabled)))
                ElseIf m_LastState Then
                    fColor = SetTextColor(destDC, ConvertVBSysColor(m_fColor(fcEnabled)))
                Else
                    fColor = SetTextColor(destDC, ConvertVBSysColor(m_fColor(fcInActive)))
                End If
                ' erase previously hilighted item
                BitBlt destDC, dcRect.Left, dcRect.Top, dcRect.Right - dcRect.Left, dcRect.Bottom - dcRect.Top, m_MenuDC, .Left, .Top, vbSrcCopy
                DrawText destDC, mCaption, -1, dcRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
            End With
            SetTextColor destDC, fColor
            ' unselect all
            SelectObject destDC, hFont
            If RefreshFlag = 0 Then
                m_CurSelect = MNU_Reset ' reset to none selected
            Else
                If RefreshFlag = MNU_Refresh Then m_CurSelect = itemSelect
            End If
        End If
    End If
    If (RefreshFlag <> 0 Or itemSelect <> m_CurSelect) And itemSelect > -1 Then
        ' no repeating and a new item will be selected
        If destDC = 0 Then  ' setup DC as needed
            destDC = GetWindowDC(p_Hwnd)
            hMnuBmp = SelectObject(m_MenuDC, m_bmpMenuBar)
            SetBkMode destDC, 3
            SelectClipRgn destDC, clipRgn
        End If
        m_CurSelect = itemSelect    ' cache newest selection
        ' shift rect to dc coords
        dcRect = mnuItem(m_CurSelect).mRect
        OffsetRect dcRect, mBar.Left, mBar.Top
        BitBlt destDC, dcRect.Left, dcRect.Top, dcRect.Right - dcRect.Left, dcRect.Bottom - dcRect.Top, m_MenuDC, mnuItem(m_CurSelect).mRect.Left, mnuItem(m_CurSelect).mRect.Top, vbSrcCopy
        InflateRect dcRect, -1, -1
        If (mnuItem(m_CurSelect).Flags And MF_DISABLED) <> MF_DISABLED Then DrawHilite destDC, dcRect, ((m_TrackLevel Or 2) = m_TrackLevel)
        If (mnuItem(m_CurSelect).Flags And MF_DISABLED) = MF_DISABLED Then