ctxhookmenu.ctl

来自「非常漂亮的VB控件」· CTL 代码 · 共 1,494 行 · 第 1/5 页

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
#If DebugMode Then
    Private m_sDebugID          As String
#End If

Private Enum UcsInitMeniType
    ucsIniMenu = 0
    ucsIniMainMenu
    ucsIniExitMenuLoop
    ucsIniEnterMenuLoop
    ucsIniParentForm
End Enum
'缺省属性值:
Const m_def_UseSystemColor = 1
'Const m_def_UseSystemColor = 0
Const m_def_SelMenuBorder = 0
Const m_def_SelMenuBack = 0
Const m_def_SelMenuFore = 0
Const m_def_SelCheckBack = 0
Const m_def_MenuBorder = 0
Const m_def_MenuBack = 0
Const m_def_MenuFore = 0
Const m_def_CheckBack = 0
Const m_def_CheckFore = 0
Const m_def_DisabledMenuBorder = 0
Const m_def_DisabledMenuBack = 0
Const m_def_DisabledMenuFore = 0
Const m_def_MenuBarBack = 0
Const m_def_MenuPopupBack = 0
'属性变量:
Dim m_UseSystemColor As Boolean
'Dim m_UseSystemColor As Boolean
Dim m_SelMenuBorder As OLE_COLOR
Dim m_SelMenuBack As OLE_COLOR
Dim m_SelMenuFore As OLE_COLOR
Dim m_SelCheckBack As OLE_COLOR
Dim m_MenuBorder As OLE_COLOR
Dim m_MenuBack As OLE_COLOR
Dim m_MenuFore As OLE_COLOR
Dim m_CheckBack As OLE_COLOR
Dim m_CheckFore As OLE_COLOR
Dim m_DisabledMenuBorder As OLE_COLOR
Dim m_DisabledMenuBack As OLE_COLOR
Dim m_DisabledMenuFore As OLE_COLOR
Dim m_MenuBarBack As OLE_COLOR
Dim m_MenuPopupBack As OLE_COLOR



'==============================================================================
' Properties
'==============================================================================

Property Get SelectDisabled() As Boolean
    SelectDisabled = m_bSelectDisabled
End Property

Property Let SelectDisabled(ByVal bValue As Boolean)
    m_bSelectDisabled = bValue
    PropertyChanged
End Property

Property Get BitmapSize() As Long
    BitmapSize = m_lBitmapSize
End Property

Property Let BitmapSize(ByVal lValue As Long)
    m_lBitmapSize = lValue
    pvGetMeasures
    PropertyChanged
End Property

Property Get UseSystemFont() As Boolean
    UseSystemFont = m_bUseSystemFont
End Property

Property Let UseSystemFont(ByVal bValue As Boolean)
    m_bUseSystemFont = bValue
    pvGetMeasures
    PropertyChanged
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 Get frContainerMenus() As Collection
    Dim oCtl            As Object
    
    Set frContainerMenus = New Collection
    For Each oCtl In ParentControls
        If TypeOf oCtl Is Menu Then
            frContainerMenus.Add oCtl
        End If
    Next
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
End Property

Friend Property Set frBmps(ByVal oValue As Collection)
    Set m_cBmps = oValue
    PropertyChanged
End Property

Private Property Get DEF_FONT() As StdFont
    Set DEF_FONT = New StdFont
    DEF_FONT.Name = "宋体"
    DEF_FONT.Size = 9
End Property

Private Property Get pvInitMenuMsg() As Long
    If m_lInitMenuMsg = 0 Then
        m_lInitMenuMsg = RegisterWindowMessage("InitMenuMsg")
    End If
    pvInitMenuMsg = m_lInitMenuMsg
End Property

'==============================================================================
' 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
    pvGetMeasures
    '--- subclass form
    With m_oSubclass
        #If WEAK_REF_ME Then
            .Subclass m_hFormHwnd, Me, True, True
        #Else
            .Subclass m_hFormHwnd, Me, False, True
        #End If
        .AddBeforeMsgs WM_INITMENUPOPUP, WM_MEASUREITEM, WM_DRAWITEM, _
                    WM_MDISETMENU, WM_NCCALCSIZE, WM_MENUSELECT, _
                    WM_SYSCOLORCHANGE, WM_NCDESTROY, pvInitMenuMsg, _
                    WM_ENTERMENULOOP, WM_EXITMENULOOP
    End With
    '--- special case: subclass MDI client
    hClient = FindWindowEx(hwnd, 0, STR_CLIENT_CLASS, vbNullString)
    If hClient <> 0 Then
        With m_oClientSubclass
            #If WEAK_REF_ME Then
                .Subclass hClient, Me, True, True
            #Else
                .Subclass hClient, Me, False, True
            #End If
            .AddBeforeMsgs WM_MDISETMENU
        End With
    End If
End Sub

Public Sub SetBitmap(Menu As Object, Pic As StdPicture, Optional MaskColor As OLE_COLOR = MASK_COLOR)
    SetBitmapByCaption pvGetCtlName(Menu), Pic, MaskColor
End Sub

Public Sub SetBitmapByCaption(ByVal sCtlName As String, Pic As StdPicture, Optional MaskColor As OLE_COLOR = MASK_COLOR)
    Dim sKey            As String
    
    On Error Resume Next
    sKey = "#" & sCtlName
    m_cBmps.Remove sKey
    If Not Pic Is Nothing Then
        m_cBmps.Add Array(Pic, MaskColor, sKey), sKey
    End If
    PropertyChanged
End Sub

Private Function pvGetCtlName(ByVal oCtl As Control) As String
    On Error Resume Next
    If oCtl.Index < 0 Then
        pvGetCtlName = oCtl.Name
    Else
        pvGetCtlName = oCtl.Name & ":" & oCtl.Index
    End If
End Function

Private Function pvHM2Pix(ByVal Value As Double) As Double
   pvHM2Pix = Value * 1440 / 2540 / Screen.TwipsPerPixelX
End Function

Private Function pvGetLuminance(ByVal clrColor As Long) As Long
    Dim rgbColor        As UcsRgbQuad
    
    OleTranslateColor clrColor, 0, VarPtr(rgbColor)
    pvGetLuminance = (rgbColor.R * 76& + rgbColor.G * 150& + rgbColor.b * 29&) \ 255&
End Function

Private Function pvGetBitmapDimmed(ByVal oPic As StdPicture, ByVal MaskColor As OLE_COLOR) As cMemDC
    Dim lI              As Long
    Dim lJ              As Long
    
    Set pvGetBitmapDimmed = New cMemDC
    With pvGetBitmapDimmed
        .Init BitmapSize + 2, BitmapSize + 2
        .Cls MASK_COLOR
        .PaintPicture oPic, (.Width - pvHM2Pix(oPic.Width)) \ 2, (.Height - pvHM2Pix(oPic.Height)) \ 2, clrMask:=MaskColor
        For lJ = 0 To BitmapSize
            For lI = 0 To BitmapSize
                If .GetPixel(lI, lJ) <> MASK_COLOR Then
                    .SetPixel lI, lJ, pvAlphaBlend(m_clrMenuBack, .GetPixel(lI, lJ), 70)
                End If
            Next
        Next
    End With
End Function

Private Function pvGetBitmapRaised(ByVal oPic As StdPicture, ByVal MaskColor As OLE_COLOR) As cMemDC
    Dim lI              As Long
    Dim lJ              As Long
    
    Set pvGetBitmapRaised = New cMemDC
    With pvGetBitmapRaised
        .Init BitmapSize + 2, BitmapSize + 2
        .Cls MASK_COLOR
        .PaintPicture oPic, (.Width - pvHM2Pix(oPic.Width)) \ 2 - 1, (.Height - pvHM2Pix(oPic.Height)) \ 2 - 1, clrMask:=MaskColor
        For lJ = .Width To 2 Step -1
            For lI = .Width To 2 Step -1
                If .GetPixel(lI - 2, lJ - 2) <> MASK_COLOR And .GetPixel(lI, lJ) = MASK_COLOR Then
                    .SetPixel lI, lJ, pvAlphaBlend(m_clrSelMenuBack, vbButtonShadow, 70)
                End If
            Next
        Next
    End With
End Function

Private Function pvGetBitmapNormal(ByVal oPic As StdPicture, ByVal MaskColor As OLE_COLOR) As cMemDC
    Set pvGetBitmapNormal = New cMemDC
    With pvGetBitmapNormal
        .Init BitmapSize + 2, BitmapSize + 2
        .Cls MASK_COLOR
        .PaintPicture oPic, (.Width - pvHM2Pix(oPic.Width)) \ 2, (.Height - pvHM2Pix(oPic.Height)) \ 2, clrMask:=MaskColor
    End With
End Function

Private Function pvGetBitmapDisabled(ByVal oPic As StdPicture, ByVal MaskColor As OLE_COLOR, ByVal TresholdLuminance As Long) As cMemDC
    Dim lI              As Long
    Dim lJ              As Long
    Dim lK              As Long
    
    Set pvGetBitmapDisabled = New cMemDC
    With pvGetBitmapDisabled
        .Init BitmapSize + 2, BitmapSize + 2
        .Cls MASK_COLOR
        .PaintPicture oPic, (.Width - pvHM2Pix(oPic.Width)) \ 2 - 1, (.Height - pvHM2Pix(oPic.Height)) \ 2 - 1, clrMask:=MaskColor
        For lJ = 0 To .Width
            For lI = 0 To .Height
                lK = .GetPixel(lI, lJ)
                If lK <> MASK_COLOR Then
                    If pvGetLuminance(lK) < TresholdLuminance Then
                        .SetPixel lI, lJ, vbButtonShadow
                    Else
                        .SetPixel lI, lJ, MASK_COLOR
                    End If
                End If
            Next
        Next
    End With
End Function

Private Function pvIsHightContrast() As Boolean
    Const STR_HIGH_CONTRAST As String = "High Contrast"
    Dim hc              As HIGHCONTRAST
    
    hc.cbSize = Len(hc)
    Call SystemParametersInfo(SPI_GETHIGHCONTRAST, Len(hc), hc, 0)
    pvIsHightContrast = (hc.dwFlags And HCF_HIGHCONTRASTON) <> 0