ctxhookmenu.ctl

人事管理系统vb版,用于一般中小企业

    lpszDefaultScheme   As Long
End Type

'==============================================================================
' Constants and member vars
'==============================================================================

Private Const MASK_COLOR            As Long = &HFF00FF
Private Const DEF_SELECTDISABLED    As Boolean = True
Private Const DEF_BITMAPSIZE        As Long = 16
Private Const DEF_USESYSTEMFONT     As Boolean = True
Private Const STR_CLIENT_CLASS      As String = "MDIClient"
Private Const SEPARATOR_HEIGHT      As Long = 2

'-- Added By Gary Noble
Private Const m_def_DisplayShadow As Boolean = True
Private Const m_def_DrawStyle     As Integer = UcsMenuStyle.MS_默认
Private Const m_def_MenuDrawStyle As Integer = UcsDrawStyle.DS_普通

'-- Added by NR
Private Const m_def_AutoColumn  As Integer = 0

Private m_oSubclass             As cSubclassingThunk
Private m_oClientSubclass       As cSubclassingThunk
Private m_cMenuSubclass         As Collection
Private m_cMemDC                As Collection
Private m_cBmps                 As Collection
Private m_ptLast                As POINTAPI
Private m_hFormMenu             As Long
Private m_hFormHwnd             As Long
Private m_hParentHwnd           As Long
Private m_lEdgeWidth            As Long '--- usually 2 px
Private m_lFrameWidth           As Long '--- usually 3 px
Private m_clrSelMenuBorder      As OLE_COLOR
Private m_clrSelMenuBack        As OLE_COLOR
Private m_clrSelMenuFore        As OLE_COLOR
Private m_clrSelCheckBack       As OLE_COLOR
Private m_clrMenuBorder         As OLE_COLOR
Private m_clrMenuBack           As OLE_COLOR
Private m_clrMenuFore           As OLE_COLOR
Private m_clrCheckBack          As OLE_COLOR
Private m_clrCheckFore          As OLE_COLOR
Private m_clrDisabledMenuBorder As OLE_COLOR
Private m_clrDisabledMenuBack   As OLE_COLOR
Private m_clrDisabledMenuFore   As OLE_COLOR
Private m_clrMenuBarBack        As OLE_COLOR
Private m_clrMenuPopupBack      As OLE_COLOR

'-- Added By Gary Noble (Phantom Man - PSC)
'-- Custom Draw Menu Attributes

Private m_MenuDrawStyle         As UcsDrawStyle

'-- Flag To Take Care Of The Menu Scroll Effect
Private m_blnFirstMenuInitialize As Boolean

Private m_lMenuHeight           As Long
Private m_lTextHeight           As Long
Private m_hLastMenu             As Long
Private m_bSelectDisabled       As Boolean
Private m_lBitmapSize           As Long
Private WithEvents m_oFont      As StdFont
Attribute m_oFont.VB_VarHelpID = -1
Private m_bUseSystemFont        As Boolean
Private m_cMenuInfo             As Collection
Private m_lInitMenuMsg          As Long
Private m_bExpectingPopup       As Boolean
Private m_bConstrainedColors    As Boolean
Private m_hLastSelMenu          As Long
Private m_rcLastSelMenu         As RECT
Private m_bLastSelMenuRightAlign As Boolean

'-- Added By Gary Noble (Phantom Man - PSC)
Private m_DrawStyle             As UcsMenuStyle
Private m_UserSideBarColour     As OLE_COLOR
Private m_UserTopMenuBackColour As OLE_COLOR
Private m_UserTopMenuSelectedColour As OLE_COLOR
Private m_UserTopMenuHotColour  As OLE_COLOR
Private m_UserTopMenuHotBorderColour As OLE_COLOR
Private m_UserMenuBorderColour  As OLE_COLOR
Private m_UserCheckBackColour   As OLE_COLOR
Private m_UserCheckBorderColour As OLE_COLOR
Private m_UserGradientOne       As OLE_COLOR
Private m_UserGradientTwo       As OLE_COLOR
Private m_UserUseGradient       As Boolean
Private m_UserUseTopMenuGradient As Boolean
Private m_UserSelectedItemForeColour As OLE_COLOR
Private m_UserSelectedMenuBackColour As OLE_COLOR
Private m_UserSelectedMenuBorderColour As OLE_COLOR

Private m_DisplayShadow             As Boolean

'-- Added by NR
Private m_AutoColumn            As Integer

#If DebugMode Then
Private m_sDebugID          As String
#End If

Private Enum UcsInitMeniType
    ucsIniMenu = 0
    ucsIniMainMenu
    ucsIniExitMenuLoop
    ucsIniEnterMenuLoop
    ucsIniParentForm
    ucsIniMenuChar
End Enum
'Default Property Values:
Const m_def_RightToLeft = False
'Property Variables:
Dim m_RightToLeft As Boolean
''
Public Property Let AutoColumn(ByVal iAutoColumn As Integer)

    m_AutoColumn = iAutoColumn
    PropertyChanged

End Property

'==============================================================================
' Properties
'==============================================================================
Public Property Get AutoColumn() As Integer

    AutoColumn = m_AutoColumn

End Property '

Property Let BitmapSize(ByVal lValue As Long)

    m_lBitmapSize = lValue
    pvGetMeasures
    PropertyChanged

End Property

Property Get BitmapSize() As Long

    BitmapSize = m_lBitmapSize

End Property

Private Property Get DEF_FONT() As StdFont

    Set DEF_FONT = New StdFont
    DEF_FONT.Name = "宋体"
    DEF_FONT.Size = 9

End Property

Public Property Let DisplayShadow(ByVal New_DisplayShadow As Boolean)

    m_DisplayShadow = New_DisplayShadow
    PropertyChanged "DisplayShadow"

End Property

Public Property Get DisplayShadow() As Boolean

    DisplayShadow = m_DisplayShadow

End Property

'-- Added By Gary Noble (Phantom Man - PSC)- Custom Attributes
Public Property Get DrawStyle() As UcsMenuStyle
Attribute DrawStyle.VB_Description = "Sets The Draw Style Of The Menu"

    DrawStyle = m_DrawStyle

End Property

Public Property Let DrawStyle(ByVal New_DrawStyle As UcsMenuStyle)

    m_DrawStyle = New_DrawStyle
    PropertyChanged "DrawStyle"
    DrawMenuBar IIf(m_hParentHwnd <> 0, m_hParentHwnd, m_hFormHwnd)

End Property

Property Get Font() As StdFont

    Set Font = m_oFont

End Property

Property Set Font(ByVal oSrc As StdFont)

    With m_oFont
        .Bold = oSrc.Bold
        .Charset = oSrc.Charset
        .Italic = oSrc.Italic
        .Name = oSrc.Name
        .Size = oSrc.Size
        .Strikethrough = oSrc.Strikethrough
        .Underline = oSrc.Underline
        .Weight = oSrc.Weight
    End With
    pvGetMeasures
    PropertyChanged

End Property

Friend Property Set frBmps(ByVal oValue As Collection)

    Set m_cBmps = oValue
    PropertyChanged

End Property

Friend Property Get frBmps() As Collection

  Dim vElem As Variant

    Set frBmps = New Collection
    For Each vElem In m_cBmps
        frBmps.Add vElem, vElem(2)
    Next vElem

End Property

Friend Property Get frContainerMenus() As Collection

  Dim oCtl            As Object

    On Error Resume Next
        Set frContainerMenus = New Collection
        For Each oCtl In ParentControls
            If TypeOf oCtl Is Menu Then
                frContainerMenus.Add oCtl
            End If
        Next oCtl
    On Error GoTo 0

End Property

Friend Sub frSubclassPopup(ByVal hwnd As Long)

  Dim oSubclass       As cSubclassingThunk
  Dim lStyle          As Long
  Dim lExStyle        As Long

    On Error Resume Next
        '--- check if this is a popup menu from main menubar
        If Not m_bExpectingPopup Then
            Exit Sub
        End If
        Set oSubclass = m_cMenuSubclass("#" & hwnd)
        If oSubclass Is Nothing Then
            Set oSubclass = New cSubclassingThunk
            With oSubclass
#If WEAK_REF_ME Then
                .Subclass hwnd, Me, True, True
#Else
                .Subclass hwnd, Me, False, True
#End If
                .AddBeforeMsgs WM_ERASEBKGND, WM_NCCALCSIZE, WM_NCPAINT, _
                               WM_WINDOWPOSCHANGING, WM_PRINT, WM_SHOWWINDOW, WM_DESTROY
            End With
            m_cMenuSubclass.Add oSubclass, "#" & hwnd
        End If
        '--- fix styles
        lExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
        lStyle = GetWindowLong(hwnd, GWL_STYLE)
        oSubclass.Tag = Array(lStyle, lExStyle)
        SetWindowLong hwnd, GWL_EXSTYLE, lExStyle And (Not WS_EX_DLGMODALFRAME) And (Not WS_EX_WINDOWEDGE)
        SetWindowLong hwnd, GWL_STYLE, lStyle And (Not WS_BORDER)
        lStyle = GetClassLong(hwnd, GCL_STYLE)
        '--- win98: check if anything to modify
        If (lStyle And CS_DROPSHADOW) <> 0 Then
            SetClassLong hwnd, GCL_STYLE, lStyle And (Not CS_DROPSHADOW)
        End If
        SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_FLAGS
    On Error GoTo 0

End Sub

'==============================================================================
' Methods
'==============================================================================

Public Sub Init(hwnd As Long)

  Dim hClient         As Long

    '--- member vars
    m_hFormHwnd = hwnd
    m_hFormMenu = GetMenu(m_hFormHwnd)
    Set m_oSubclass = New cSubclassingThunk
    Set m_oClientSubclass = New cSubclassingThunk
    '--- get appearance info and init menu