clsmenubarcontrol.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsMenuBarControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function DestroyMenu Lib "user32.dll" (ByVal hMenu As Long) As Long
Private Declare Function AppendMenu Lib "user32.dll" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetRgnBox Lib "gdi32.dll" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function CreatePopupMenu Lib "user32.dll" () As Long
Private Declare Function TrackPopupMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lprc As Any) As Long
Private Declare Function PtInRect Lib "user32.dll" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetMenuItemInfo_String Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO_String) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SetRect Lib "user32.dll" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32.dll" (ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetGDIObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DrawFrameControl Lib "user32.dll" (ByVal hDC As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
Private Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hWnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type
Private Type MENUITEMINFO_String        ' used to retrieve/store menu items
     cbSize As Long                      ' this structure is used with all O/S
     fMask As Long
     fType As Long
     fState As Long
     wID As Long
     hSubMenu As Long
     hbmpChecked As Long
     hbmpUnchecked As Long
     dwItemData As Long
     dwTypeData As String
     cch As Long
End Type
Private Type NONCLIENTMETRICS     ' used to retrieve/set system settings
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
Private Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
Private Type HotTrackingStructure
    htk_Now As Long
    htk_Was As Long
    htk_Next As Long
    htk_ESC As Boolean
    htk_FromKeyBd As Boolean
    htk_Pt As POINTAPI
End Type
Private Type MenuItemDataStructure
    ID As Long
    mRect As RECT
    Flags As Long
'    isEnabled As Boolean
'    Caption As String
End Type


Private Const DT_CALCRECT As Long = &H400
Private Const DT_CENTER As Long = &H1
Private Const DT_LEFT As Long = &H0
Private Const DT_SINGLELINE As Long = &H20
Private Const DT_VCENTER As Long = &H4
Private Const MF_DISABLED As Long = &H2&
Private Const MIIM_ID As Long = &H2
Private Const MIIM_STATE As Long = &H1
Private Const MIIM_STRING As Long = &H40
Private Const WM_CANCELMODE As Long = &H1F
Private Const WM_COMMAND As Long = &H111
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_MOUSEMOVE As Long = &H200
Private Const mouse_event_flag As Long = &H2
Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2
Private Const MOUSEEVENTF_MIDDLEDOWN As Long = &H20
Private Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Private Const MOUSEEVENTF_XDOWN As Long = &H80
Private Const MOUSEEVENTF_ABSOLUTE As Long = &H8000
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_XBUTTONDOWN As Long = &H20B
Private Const WM_NCRBUTTONDOWN As Long = &HA4
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_NCLBUTTONUP As Long = &HA2

Private Const MNU_ResetAll As Long = -1
Private Const MNU_Reset As Long = -2    ' draw appropriate selection
Private Const MNU_Refresh As Long = -3  ' exit loop, update bar appropriately

Private mnuItem() As MenuItemDataStructure

Public Event RefreshMenuBar()
Public Event GetWindowRegion(lRegion As Long)

Private m_dcBitmap As Long
Private m_bmpMenuBar As Long ' static menu bar
Private m_MenuDC As Long

Private m_mbarOffset As POINTAPI
Private m_mbarLocked As Boolean
Private m_FarExtent As Long
Private m_FarExtentPrevious As Long
Private m_SingleLineMenu As Boolean
Private m_Menu As Long
Private m_HotKeys As String
Private m_Font As Long
Private p_Hwnd As Long

Private m_LastState As Long ' whether active or not
Private m_CurSelect As Long ' last menu item highlighted
Private m_TrackLevel As Integer   ' 1=hilight only, 2=select, 4= has sysicon
Private m_Tracking As Boolean
Private m_MBarXY As POINTAPI
Private HTrack As HotTrackingStructure

Private m_fColor(0 To 3) As Long
Private m_HiliteColor(0 To 1) As Long
Private m_HiliteStyle As Integer

Private Sub Class_Initialize()
m_LastState = 2
m_CurSelect = MNU_Reset
m_fColor(fcDisabled) = vbGrayText
m_fColor(fcEnabled) = vbMenuText
m_fColor(fcInActive) = vbGrayText
m_fColor(fcSelected) = vbMenuText
m_HiliteColor(0) = vbHighlightText
m_HiliteColor(1) = vb3DShadow
End Sub

Private Sub Class_Terminate()
TrackingState = False
If m_Font Then DeleteObject m_Font
If m_MenuDC Then DeleteDC m_MenuDC
If m_dcBitmap Then DeleteObject m_dcBitmap
If m_bmpMenuBar Then DeleteObject m_bmpMenuBar
If m_Menu Then SetMenu p_Hwnd, m_Menu
m_bmpMenuBar = 0
m_dcBitmap = 0
m_Menu = 0
m_Font = 0
Erase mnuItem
End Sub

Public Property Get TrackingState() As Boolean
TrackingState = m_Tracking
End Property
Public Property Let TrackingState(isTracking As Boolean)
If isTracking Then
    m_Tracking = True   ' no routine set this to true; really used to reset
Else
    m_Tracking = False
    'If SetInputHook(False, Nothing) Then ReleaseCapture
    SetInputHook False, Nothing
    SetMenuHook False, Nothing
    'Debug.Print "trackingstate reset via property /wm_cancelmode"
End If
End Property


Public Property Set Font(newFont As StdFont)
Dim nFont As LOGFONT
If m_Font Then
    DeleteObject m_Font
Else
    Dim hDC As Long
    hDC = GetWindowDC(GetDesktopWindow())
    m_MenuDC = CreateCompatibleDC(hDC)
    ReleaseDC GetDesktopWindow(), hDC
    SetBkMode m_MenuDC, 3
End If
If newFont Is Nothing Then
    Dim ncm As NONCLIENTMETRICS
    ncm.cbSize = Len(ncm)
    ' this will return the system menu font info
    SystemParametersInfo 41, 0, ncm, 0
    nFont = ncm.lfMenuFont
Else
    With newFont
        nFont.lfFaceName = .Name & String$(32, 0)
        nFont.lfHeight = (.Size * -20) / Screen.TwipsPerPixelY
        nFont.lfItalic = Abs(.Italic)
        nFont.lfStrikeOut = Abs(.Strikethrough)
        nFont.lfUnderline = Abs(.Underline)
        nFont.lfWeight = Abs(.Bold) * 300 + 400
    End With
End If
nFont.lfCharSet = 1
m_Font = CreateFontIndirect(nFont)
End Property

Public Property Get Font() As StdFont
Dim tFont As StdFont, nFont As LOGFONT
If m_Font Then
    GetGDIObject m_Font, Len(nFont), nFont
    Set tFont = New StdFont
    With tFont
        If InStr(nFont.lfFaceName, Chr$(0)) Then
            .Name = Left$(nFont.lfFaceName, InStr(nFont.lfFaceName, Chr$(0)) - 1)
        Else
            .Name = nFont.lfFaceName
        End If
        .Bold = nFont.lfWeight > 400
        .Italic = nFont.lfItalic <> 0
        .Underline = nFont.lfUnderline <> 0
        .Strikethrough = nFont.lfStrikeOut <> 0
        If nFont.lfHeight < 0 Then
            .Size = (nFont.lfHeight * Screen.TwipsPerPixelY) / -20
        Else
            .Size = 8.25
        End If
    End With
Else
    Set tFont = New StdFont
    tFont.Name = "Tahoma"
    tFont.Size = 8.25
End If
On Error Resume Next
Set Font = tFont
End Property

Public Property Let FontColor(lState As FontStateColorConstants, lColor As Long)
If lState < 0 Or lState > fcInActive Then Exit Property
m_fColor(lState) = lColor
ForceMenuBarRepaint
End Property
Public Property Get FontColor(lState As FontStateColorConstants) As Long
If lState < 0 Or lState > fcInActive Then Exit Property
FontColor = m_fColor(lState)
End Property

Public Property Get WindowMenu(dbgID As String) As Long
WindowMenu = m_Menu
End Property

Public Property Let WindowMenu(dbgID As String, Zero As Long)
Dim hMenu As Long
hMenu = GetMenu(p_Hwnd)
If hMenu Then
    m_Menu = hMenu
    'Debug.Print " resetting menu via mnubar resetmenu from "; dbgID