cxpmenu.cls

VB下开发Windows XP风格的控件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CXPMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_AND As Long = 1
Private Const RGN_COPY As Long = 5
Private Const RGN_DIFF As Long = 4
Private Const RGN_MAX As Long = RGN_COPY
Private Const RGN_MIN As Long = RGN_AND
Private Const RGN_OR As Long = 2
Private Const RGN_XOR As Long = 3

Private Const WS_EX_CLIENTEDGE As Long = &H200
Private Const WS_EX_DLGMODALFRAME As Long = &H1
Private Const WS_EX_WINDOWEDGE As Long = &H100

Private Const DT_NOCLIP As Long = &H100
Private Const DT_SINGLELINE As Long = &H20
Private Const DT_VCENTER As Long = &H4

'Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function EqualRgn Lib "gdi32" (ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRGN As Long, lpRect As RECT) As Long
Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) 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 TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function RoundRect Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRGN As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRGN As Long) As Long
Private Const GWL_EXSTYLE As Long = (-20)

Private Const ODS_CHECKED As Long = &H8
Private Const ODS_COMBOBOXEDIT As Long = &H1000
Private Const ODS_DEFAULT As Long = &H20
Private Const ODS_DISABLED As Long = &H4
Private Const ODS_FOCUS As Long = &H10
Private Const ODS_GRAYED As Long = &H2
Private Const ODS_HOTLIGHT As Long = &H40
Private Const ODS_INACTIVE As Long = &H80
Private Const ODS_NOACCEL As Long = &H100
Private Const ODS_NOFOCUSRECT As Long = &H200
Private Const ODS_SELECTED As Long = &H1

Private Const SRCCOPY As Long = &HCC0020
Private Const PS_SOLID As Long = 0
Private Const COLOR_MENU  As Long = 4
Private Const COLOR_MENUTEXT  As Long = 8
Private Const COLOR_HIGHLIGHT As Long = 13
Private Const COLOR_HIGHLIGHTTEXT  As Long = 14
Private Const NEWTRANSPARENT  As Long = 3

Private Const BDR_SUNKENOUTER  As Long = &H2
Private Const BDR_RAISEDINNER  As Long = &H4
Private Const EDGE_ETCHED  As Long = BDR_RAISEDINNER
Private Const BF_BOTTOM  As Long = &H8
Private Const BF_LEFT  As Long = &H1
Private Const BF_RIGHT  As Long = &H4
Private Const BF_TOP  As Long = &H2
Private Const BF_RECT  As Long = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Const SubMenuArrowColor As Long = &H0
Private Const CheckBackColor As Long = &HC08080
Private Const CheckBoxColor As Long = &H800000
Private Const CheckMarkColor As Long = &H0
Private Const DisabledColor  As Long = &HA5A5A5
Private Const FontBackColor  As Long = &HF6F6F6
Private Const FontForeColor  As Long = &H80000012
Private Const SelBackColor  As Long = &HD1ADAD
Private Const SelBoxColor As Long = &H800000
Private Const SeparatorColor As Long = &HA5A5A5
Private Const ShadowColor  As Long = &H9C8181

Private Const DRAW_WIDTH  As Long = 1
Private Const PicWidth  As Long = 20
Private Const PicToText As Long = 6

'Private m_MenuCaption As String
Private m_DrawStruct As DRAWITEMSTRUCT
Private m_DrawItem As DRAWITEMSTRUCT
Private m_Style As Long '1-standard XP menu,2-gradient menu
Private m_LR As Integer
Private m_LG As Integer
Private m_LB As Integer
Private m_RR As Integer
Private m_RG As Integer
Private m_RB As Integer

Private l_LR As Long
Private l_LG As Long
Private l_LB As Long
Private l_RR As Long
Private l_RG As Long
Private l_RB As Long

Public Depth As Long
Public icon As Long
Public hParentMenu As Long
Public m_hMain As Long
Public m_hMenuID As Long

Private Function LongToUShort(ByVal ULong As Long) As Integer

    If (ULong < 32768) Then
        LongToUShort = ULong
      Else 'NOT (ULONG...
        LongToUShort = CInt(ULong - &H10000)
    End If

End Function

'-----------------------------------------------------
'System Vars    Put&Get Value
'-----------------------------------------------------
Public Property Get MenuId() As Long

    MenuId = m_hMenuID

End Property

Public Property Get Caption() As String

  Dim s As String

    s = Space(256)
    GetMenuString hParentMenu, MenuId, s, 255, 0
    Caption = Left(s, InStr(s, Chr(0)) - 1)

End Property

'-----------------------------------------------------
'初始化MENUID和菜单名称及图片
'-----------------------------------------------------
Public Sub InitMenu(ByVal hParent As Long, ByVal hMenuID As Long, ByVal dep As Long, ByVal style As Long, ByVal leftcolor As Long, ByVal rightcolor As Long, Optional ByVal lIcon As Long)

    m_hMenuID = hMenuID
    Depth = dep
    icon = lIcon
    hParentMenu = hParent
    m_Style = style
    l_LR = leftcolor Mod 256
    l_LG = (leftcolor Mod 65536 - m_LR) \ 256
    l_LB = (leftcolor - m_LG * 256 - m_LR) \ 65536
    l_RR = rightcolor Mod 256
    l_RG = (rightcolor Mod 65536 - m_RR) \ 256
    l_RB = (rightcolor - m_RG * 256 - m_RR) \ 65536

    l_LR = l_LR * 256
    l_LG = l_LG * 256
    l_LB = l_LB * 256
    l_RR = l_RR * 256
    l_RG = l_RG * 256
    l_RB = l_RB * 256

    'MsgBox Hex$(l_LR) & " " & Hex$(l_LG) & " " & Hex$(l_LB)
    'MsgBox Hex$(l_RR) & " " & Hex$(l_RG) & " " & Hex$(l_RB)

    m_LR = LongToUShort(l_LR)
    m_LG = LongToUShort(l_LG)
    m_LB = LongToUShort(l_LB)
    m_RR = LongToUShort(l_RR)
    m_RG = LongToUShort(l_RG)
    m_RB = LongToUShort(l_RB)

    'MsgBox Hex$(m_LR) & " " & Hex$(m_LG) & " " & Hex$(m_LB)
    'MsgBox Hex$(m_RR) & " " & Hex$(m_RG) & " " & Hex$(m_RB)

End Sub

Public Sub InitDraw(ByVal hDC As Long, ByVal ItemAction As Long, ByVal ItemId As Long, ByVal ItemState As Long, ByVal P_Left As Long, ByVal P_Top As Long, ByVal P_Bottom As Long, ByVal P_Right As Long)

    m_DrawStruct.hDC = hDC
    m_DrawStruct.ItemId = ItemId
    m_DrawStruct.ItemState = ItemState
    m_DrawStruct.rcItem.Top = P_Top
    m_DrawStruct.rcItem.Right = P_Right
    m_DrawStruct.rcItem.Bottom = P_Bottom
    m_DrawStruct.rcItem.Left = P_Left
    m_DrawStruct.ItemAction = ItemAction

End Sub

Private Function SetRect(ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As RECT