ctxhookmenu.ctl

来自「很美的窗口控件,让你的系统界面接近WINDOWS界面...不信你」· CTL 代码 · 共 1,506 行 · 第 1/5 页

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

'==============================================================================
' 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 = "Tahoma"
    DEF_FONT.Size = 8
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
    If Not pvIsHightContrast Then
        '--- hack: not working for language other than english!!!
        pvIsHightContrast = (Left(pvRegGetKeyValue(HKEY_CURRENT_USER, "Control Panel\Appearance", "Current"), Len(STR_HIGH_CONTRAST)) = STR_HIGH_CONTRAST)
    End If
End Function

Private Function pvIsAppearanceXpStyle() As Boolean
    Dim lValue          As Long
    
    SystemParametersInfo SPI_GETFLATMENU, 0, lValue, 0
    pvIsAppearanceXpStyle = (lValue <> 0)
End Function

Private Function pvGetColorBits() As Long
    Dim hDC             As Long
    
    hDC = GetWindowDC(GetDesktopWindow())
    pvGetColorBits = GetDeviceCaps(hDC, BITSPIXEL) * GetDeviceCaps(hDC, PLANES)
    Call ReleaseDC(GetDesktopWindow(), hDC)
End Function

Private Sub pvGetMeasures()
    '--- get border widths
    m_lEdgeWidth = GetSystemMetrics(SM_CXEDGE)
    m_lFrameWidth = GetSystemMetrics(SM_CXDLGFRAME)
    m_bConstrainedColors = pvIsHightContrast() Or pvGetColorBits() <= 8
    If m_bConstrainedColors Then
        '--- calc high-contrast colors
        m_clrSelMenuBorder = vbButtonText
        If pvIsHightContrast() Then
            m_clrSelMenuBack = vbHighlight
            m_clrSelMenuFore = vbHighlightText
        Else
            m_clrSelMenuFore = vbWindowText
            m_clrSelMenuBack = vbWindowBackground
        End If
        m_clrCheckBack = m_clrSelMenuBack
        m_clrCheckFore = m_clrSelMenuFore
        m_clrSelCheckBack = m_clrSelMenuBack
        m_clrMenuBorder = vbButtonText
        m_clrMenuBack = vbButtonFace
        m_clrMenuFore = vbMenuText
        m_clrDisabledMenuBorder = vbButtonText
        m_clrDisabledMenuBack = m_clrSelMenuBack ' pvAlphaBlend(m_clrMenuBack, vbWindowBackground, 128)