ctxhookmenu.ctl

很美的窗口控件,让你的系统界面接近WINDOWS界面...不信你

        '--- if not found -> degrade to 50px width
        If mis.itemID <> lId Or hMenu = 0 Then
            mis.itemWidth = 50
            CopyMemory lParam, VarPtr(mis), Len(mis)
            Exit Function
        End If
        With New cMemDC
            .Init
            If UseSystemFont Then
                Set .Font = .SystemMenuFont
            Else
                Set .Font = Font
            End If
            If (lType And MFT_SEPARATOR) = MFT_SEPARATOR Then
                mis.itemHeight = SEPARATOR_HEIGHT
            Else
                mis.itemHeight = m_lMenuHeight
            End If
            '--- calc text width minus underlines
            .DrawText sText, 0, 0, lRight, 0, DT_CALCRECT Or DT_SINGLELINE
            mis.itemWidth = lRight + IIf(bMainMenu, 2, m_lMenuHeight + 8 + m_lMenuHeight)
        End With
        CopyMemory lParam, VarPtr(mis), Len(mis)
        '--- handled
        pvMeasureItem = True
    End If
End Function

Private Function pvFindIconInfo(ByVal sCaption As String) As Variant
'--- ToDo: better handling
    Dim oCtl            As Object
    
    On Error Resume Next
    For Each oCtl In ParentControls
        If TypeOf oCtl Is Menu Then
            If Split(oCtl.Caption, vbTab)(0) <> sCaption Then
            Else
                pvFindIconInfo = m_cBmps("#" & pvGetCtlName(oCtl))
                Exit Function
            End If
        End If
    Next
End Function

Private Function pvDrawItem(ByVal lParam As Long) As Boolean
    Dim lI              As Long
    Dim lJ              As Long
    Dim lK              As Long
    Dim clrBack         As Long
    Dim clrBorder       As Long
    Dim dis             As DRAWITEMSTRUCT
    Dim hMenu           As Long
    Dim sText           As String
    Dim lType           As Long
    Dim bMainMenu       As Boolean
    Dim lId             As Long
    Dim rc              As RECT
    Dim lState          As Long
    Dim vPic            As Variant
    Dim oPicMemDC       As cMemDC
    Dim vSplit          As Variant
    Dim mii             As MENUITEMINFO

    '--- dereference structure
    CopyMemory VarPtr(dis), lParam, Len(dis)
    If dis.CtlType = ODT_MENU Then
        '--- win95: int->long conversion troubles
        If Not IsNT Then
            dis.itemID = (dis.itemID And &HFFFF&)
        End If
        '--- get menu info
        Call pvGetMenuInfo(dis.itemData, hMenu, sText, lType, bMainMenu, lId)
        '--- if not found -> bail out immediately
        If dis.itemID <> lId Or dis.hwndItem <> hMenu Then
            Exit Function
        End If
        '--- get menu state
        lState = GetMenuState(hMenu, dis.itemID, MF_BYCOMMAND)
        With New cMemDC
            .Init hMemoryDC:=dis.hDC
            '--- setup memory (buffer) device-context
            .Init dis.rcItem.Right - dis.rcItem.Left + 3, dis.rcItem.Bottom - dis.rcItem.Top + 1, dis.hDC
            .LoadBlt dis.hDC, dis.rcItem.Left, dis.rcItem.Top
            SetViewportOrgEx .hDC, -dis.rcItem.Left, -dis.rcItem.Top, 0
            '--- init device-context settings (font)
            .BackStyle = BS_TRANSPARENT
            If Not UseSystemFont Then
                '--- merge fonts
                Dim oFnt As StdFont
                Set oFnt = .Font
                oFnt.Name = Font.Name
                oFnt.Size = Font.Size
                oFnt.Bold = oFnt.Bold Or Font.Bold
                oFnt.Italic = oFnt.Italic Or Font.Italic
                oFnt.Underline = oFnt.Underline Or Font.Underline
                oFnt.Strikethrough = oFnt.Strikethrough Or Font.Strikethrough
                Set .Font = oFnt
            End If
            '--- check if drawing main menu item
            If bMainMenu Then
                '--- fill background
                .FillRect dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Right + 3, dis.rcItem.Bottom, m_clrMenuBarBack
                If (lState And MF_GRAYED) = 0 Then
                    .ForeColor = m_clrMenuFore
                    If (dis.itemState And ODS_SELECTED) <> 0 Then
                        .Rectangle dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Right, dis.rcItem.Bottom, m_clrMenuBack, , m_clrMenuBorder
                    ElseIf (dis.itemState And ODS_HOTLIGHT) <> 0 Then
                        .Rectangle dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Right, dis.rcItem.Bottom, m_clrSelMenuBack, , m_clrSelMenuBorder
                        .ForeColor = m_clrSelMenuFore
                    End If
                Else
                    .ForeColor = m_clrDisabledMenuFore
                End If
                '--- draw text
                .DrawText sText, dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Right, dis.rcItem.Bottom, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
                '--- draw main menu shadow
                If (dis.itemState And ODS_SELECTED) <> 0 Then
                    If m_bConstrainedColors Then
                        .FillRect dis.rcItem.Right, dis.rcItem.Top + 3, dis.rcItem.Right + 2, dis.rcItem.Bottom, vbButtonShadow
                    Else
                        For lJ = 0 To 2
                            For lK = 3 To dis.rcItem.Bottom - dis.rcItem.Top - 1
                                .SetPixel dis.rcItem.Right + lJ, dis.rcItem.Top + lK, pvAlphaBlend(vbBlack, .GetPixel(dis.rcItem.Right + lJ, dis.rcItem.Top + lK), &H40 - lJ * (&H40 / 3))
                            Next
                        Next
                    End If
                End If
            Else
                If (lType And MFT_SEPARATOR) = 0 Then
                    vSplit = Split(sText, vbTab)
                    If UBound(vSplit) >= 0 Then
                        '--- figure out current bitmap appearance
                        vPic = pvFindIconInfo(vSplit(0))
                        If IsArray(vPic) Then
                            If Not vPic(0) Is Nothing Then
                                If (lState And MF_DISABLED) <> 0 Then
                                    Set oPicMemDC = pvGetBitmapDisabled(vPic(0), vPic(1), pvGetLuminance(m_clrMenuBack))
                                ElseIf (lState And MF_CHECKED) <> 0 Then
                                    Set oPicMemDC = pvGetBitmapNormal(vPic(0), vPic(1))
                                ElseIf (dis.itemState And ODS_SELECTED) <> 0 Then
                                    Set oPicMemDC = pvGetBitmapRaised(vPic(0), vPic(1))
                                Else
                                    Set oPicMemDC = pvGetBitmapDimmed(vPic(0), vPic(1))
                                End If
                            End If
                        End If
                    End If
                End If
                '--- fill background
                If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                    .FillRect dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Left + m_lMenuHeight + 3, dis.rcItem.Bottom, m_clrMenuBack
                Else
                    .FillRect dis.rcItem.Right - m_lMenuHeight - 4, dis.rcItem.Top, dis.rcItem.Right - 1, dis.rcItem.Bottom, m_clrMenuBack
                End If
                '--- get ID of last menu item in current (popup) menu
                mii.cbSize = Len(mii) - IIf(OsVersion >= &H40A, 0, 4)
                mii.fMask = MIIM_ID
                Call GetMenuItemInfo(hMenu, GetMenuItemCount(hMenu) - 1, 1, mii)
                '--- if current item is the last one in the popup menu -> paint a white line at the bottom
                If mii.wID = lId Then
                    .FillRect dis.rcItem.Left, dis.rcItem.Bottom - 1, dis.rcItem.Right - 1, dis.rcItem.Bottom, m_clrMenuPopupBack
                End If
                If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                    .FillRect dis.rcItem.Left + m_lMenuHeight + 3, dis.rcItem.Top, dis.rcItem.Right - 1, dis.rcItem.Bottom, m_clrMenuPopupBack
                Else
                    .FillRect dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Right - m_lMenuHeight - 4, dis.rcItem.Bottom, m_clrMenuPopupBack
                End If
                .FillRect dis.rcItem.Right - 1, dis.rcItem.Top, dis.rcItem.Right, dis.rcItem.Bottom, m_clrMenuBorder
                If (lType And MFT_SEPARATOR) = MFT_SEPARATOR Then
                    '--- draw separator line
                    If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                        .FillRect dis.rcItem.Left + m_lMenuHeight + 10, (dis.rcItem.Top + dis.rcItem.Bottom) \ 2 - 1, dis.rcItem.Right, (dis.rcItem.Top + dis.rcItem.Bottom) \ 2, m_clrMenuBorder
                    Else
                        .FillRect dis.rcItem.Left, (dis.rcItem.Top + dis.rcItem.Bottom) \ 2 - 1, dis.rcItem.Right - 1 - m_lMenuHeight - 10, (dis.rcItem.Top + dis.rcItem.Bottom) \ 2, m_clrMenuBorder
                    End If
                Else
                    '--- if selected -> item background rect (enabled or disabled)
                    If (lState And MF_GRAYED) = 0 Then
                        If (dis.itemState And ODS_SELECTED) <> 0 Then
                            .ForeColor = m_clrSelMenuFore
                            .Rectangle dis.rcItem.Left + 1, dis.rcItem.Top, dis.rcItem.Right - 2, dis.rcItem.Bottom - 1, m_clrSelMenuBack, , m_clrSelMenuBorder
                        Else
                            .ForeColor = m_clrMenuFore
                        End If
                    Else
                        .ForeColor = m_clrDisabledMenuFore
                        If (dis.itemState And ODS_SELECTED) <> 0 And SelectDisabled Then
                            .Rectangle dis.rcItem.Left + 1, dis.rcItem.Top, dis.rcItem.Right - 2, dis.rcItem.Bottom - 1, m_clrDisabledMenuBack, , m_clrDisabledMenuBorder
                        End If
                    End If
                    '--- draw check square background and border
                    If (lState And MF_CHECKED) <> 0 Then
                        lI = (m_lMenuHeight - BitmapSize - 1) \ 2
                        lJ = (m_lMenuHeight - BitmapSize - 5) \ 2
                        If (lState And MF_DISABLED) <> 0 Then
                            clrBack = m_clrDisabledMenuBack
                            clrBorder = m_clrDisabledMenuBorder
                        ElseIf (dis.itemState And ODS_SELECTED) <> 0 Then
                            clrBack = m_clrSelCheckBack
                            clrBorder = m_clrSelMenuBorder
                        Else
                            clrBack = m_clrCheckBack
                            clrBorder = m_clrSelMenuBorder
                        End If
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            .Rectangle dis.rcItem.Left + lI, dis.rcItem.Top + lJ, dis.rcItem.Left + lI + BitmapSize + 4, dis.rcItem.Top + lJ + BitmapSize + 4, clrBack, , clrBorder
                        Else
                            .Rectangle dis.rcItem.Right - 4 - m_lMenuHeight + lI, dis.rcItem.Top + lJ, dis.rcItem.Right - 4 - m_lMenuHeight + lI + BitmapSize + 4, dis.rcItem.Top + lJ + BitmapSize + 4, clrBack, , clrBorder
                        End If
                    End If
                    '--- draw bitmap or check
                    If Not oPicMemDC Is Nothing Then
                        lI = (m_lMenuHeight - BitmapSize - 1) \ 2 - 1
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            oPicMemDC.TransBlt .hDC, dis.rcItem.Left + lI + 2, dis.rcItem.Top + lI, BitmapSize + 2, BitmapSize + 2, clrMask:=MASK_COLOR
                        Else
                            oPicMemDC.TransBlt .hDC, dis.rcItem.Right - 4 - m_lMenuHeight + lI + 2, dis.rcItem.Top + lI, BitmapSize + 2, BitmapSize + 2, clrMask:=MASK_COLOR
                        End If
                    ElseIf (lState And MF_CHECKED) <> 0 Then
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            lI = dis.rcItem.Left + m_lMenuHeight \ 2 - 2
                        Else
                            lI = dis.rcItem.Right - 4 - m_lMenuHeight \ 2 - 2
                        End If
                        For lJ = 0 To 2
                            .DrawLine lI + lJ, dis.rcItem.Top + m_lMenuHeight \ 2 - 2 + lJ + 1, lI + lJ, dis.rcItem.Top + m_lMenuHeight \ 2 + lJ + 1, m_clrCheckFore
                        Next
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            lI = dis.rcItem.Left + m_lMenuHeight \ 2
                        Else
                            lI = dis.rcItem.Right - 4 - m_lMenuHeight \ 2
                        End If
                        For lJ = 1 To 4
                            .DrawLine lI + lJ, dis.rcItem.Top + m_lMenuHeight \ 2 - lJ + 1, lI + lJ, dis.rcItem.Top + m_lMenuHeight \ 2 - lJ + 3, m_clrCheckFore
                        Next
                    End If
                    '--- draw text
                    If UBound(vSplit) >= 0 Then
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            .DrawText vSplit(0), dis.rcItem.Left + m_lMenuHeight + 10, dis.rcItem.Top, dis.rcItem.Right - m_lMenuHeight, dis.rcItem.Bottom - 1, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
                        Else
                            .DrawText vSplit(0), dis.rcItem.Left + m_lMenuHeight, dis.rcItem.Top, dis.rcItem.Right - 1 - m_lMenuHeight - 10, dis.rcItem.Bottom - 1, DT_RIGHT Or DT_SINGLELINE Or DT_VCENTER
                        End If
                    End If
                    '--- draw shortcut keys
                    If UBound(vSplit) > 0 Then
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            .DrawText vSplit(1), dis.rcItem.Left + m_lMenuHeight + 10, dis.rcItem.Top, dis.rcItem.Right - m_lMenuHeight, dis.rcItem.Bottom - 1, DT_RIGHT Or DT_SINGLELINE Or DT_VCENTER
                        Else
                            .DrawText vSplit(1), dis.rcItem.Left + m_lMenuHeight, dis.rcItem.Top, dis.rcItem.Right - 1 - m_lMenuHeight - 10, dis.rcItem.Bottom - 1, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
                        End If
                    End If
                    '--- draw submenu arrow (if necessary)
                    If (lState And MF_POPUP) <> 0 Then
                        lI = (dis.rcItem.Top + dis.rcItem.Bottom - 1) \ 2
                        If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                            lJ = dis.rcItem.Right - m_lMenuHeight \ 3 - 4
                        Else
                            lJ = dis.rcItem.Left + m_lMenuHeight * 2 \ 3 - 4
                        End If
                        For lK = (m_lTextHeight + 3) \ 6 To 0 Step -1
                            If (lType And MFT_RIGHTJUSTIFY) = 0 Then
                                .DrawLine lJ - lK, lI - lK, lJ - lK, lI + lK + 1, .ForeColor
                            Else
                                .DrawLine lJ + lK, lI - lK, lJ + lK, lI + lK + 1, .ForeColor
                            End If
                        Next
                    End If
                End If
            End If
            If .IsMemoryDC Then
                SetViewportOrgEx .hDC, 0, 0, 0
                .BitBlt dis.hDC, dis.rcItem.Left, dis.rcItem.Top
            End If
        End With
        '--- prevent further drawing (esp sub-menu arrow) and reduce flicker
        ExcludeClipRect dis.hDC, dis.rcItem.Left, dis.rcItem.Top, dis.rcItem.Right, dis.rcItem.Bottom
        '--- handled
        pvDrawItem = True
    End If
End Function

Private Sub pvWritePictureProperty( _
            oBag As PropertyBag, _
            sPropName As String, _
            ByVal oPic As StdPicture, _
            Optional DefaultValue As Variant)
    Dim ii              As ICONINFO
    Dim hr              As Long
    Dim oMemDC          As cMemDC
    
    If Not oPic Is Nothing Then
        If oPic.Type = vbPicTypeIcon Then
            Set oMemDC = New cMemDC
            hr = GetIconInfo(oPic.handle, ii)
            With New PropertyBag
                Call .WriteProperty("c", oMemDC.BitmapToPicture(ii.hbmColor))
                Call .WriteProperty("m", oMemDC.BitmapToPicture(ii.hbmMask))
                Call oBag.WriteProperty(sPropName, .Contents, DefaultValue)
            End With
            Exit Sub
        End If