ctxhookmenu.ctl

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

    End If
    '--- else
    Call oBag.WriteProperty(sPropName, oPic, DefaultValue)
End Sub

Private Function pvReadPictureProperty( _
            oBag As PropertyBag, _
            sPropName As String, _
            Optional DefaultValue As Variant) As StdPicture
    Dim ii              As ICONINFO
    Dim hr              As Long
    Dim imgColor        As StdPicture
    Dim imgMask         As StdPicture
    
    If IsArray(oBag.ReadProperty(sPropName, DefaultValue)) Then
        With New PropertyBag
            .Contents = oBag.ReadProperty(sPropName, DefaultValue)
            Set imgColor = .ReadProperty("c")
            Set imgMask = .ReadProperty("m")
        End With
        ii.fIcon = 1
        ii.hbmColor = imgColor.handle
        ii.hbmMask = imgMask.handle
        With New cMemDC
            Set pvReadPictureProperty = .IconToPicture(CreateIconIndirect(ii))
        End With
    Else
        Set pvReadPictureProperty = oBag.ReadProperty(sPropName, DefaultValue)
    End If
End Function

Private Function pvGetBackground(ByVal hwnd As Long) As cMemDC
    Dim oMemDC          As cMemDC
    Dim rc              As RECT
    Dim rcItem          As RECT
    Dim rcPopup         As RECT
    Dim rcPopupBtm      As RECT
    Dim lI              As Long
    Dim lJ              As Long
    Dim lWidth          As Long
    Dim lHeight         As Long
    Dim v               As Variant
    Dim hWndFrm         As Long
    Dim lHorShadowStart As Long
    Dim lHorShadowEnd   As Long
    
    On Error Resume Next
    Set oMemDC = m_cMemDC("#" & hwnd)
    If oMemDC Is Nothing Then
        GetWindowRect hwnd, rc
        Set oMemDC = New cMemDC
        oMemDC.Init rc.Right - rc.Left, rc.Bottom - rc.Top
        With New cMemDC
            .Init , , , GetWindowDC(GetDesktopWindow())
            .BitBlt oMemDC.hDC, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top, m_ptLast.X, m_ptLast.Y
            Call ReleaseDC(GetDesktopWindow(), .hDC)
        End With
        lWidth = rc.Right - rc.Left - 2 * m_lFrameWidth + 1
        lHeight = rc.Bottom - rc.Top - 2 * m_lFrameWidth + 3
        lHorShadowEnd = lWidth - 1 + 3
        With oMemDC
            .Rectangle 0, 0, lWidth, lHeight, vbWindowBackground, , m_clrMenuBorder
            '--- visually improves performance to clear the left band here
            .FillRect 1, 2, m_lMenuHeight + 4, lHeight - 2, m_clrMenuBack
            Call GetMenuItemRect(m_hFormHwnd, m_hLastMenu, 0, rcItem)
            '--- fix the line right below the main menu
            For lI = 0 To GetMenuItemCount(m_hFormMenu) - 1
                '--- find opened main menu item
                If (GetMenuState(m_hFormMenu, lI, MF_BYPOSITION) And MF_HILITE) <> 0 Then
                    If m_hLastMenu = GetSubMenu(m_hFormMenu, lI) Then
                        '--- get its popup menu dimensions
                        hWndFrm = IIf(m_hParentHwnd <> 0, m_hParentHwnd, m_hFormHwnd)
                        '--- win98: can't pass NULL for hwnd (so use hWndFrm)
                        Call GetMenuItemRect(hWndFrm, m_hLastMenu, 0, rcPopup)
                        Call GetMenuItemRect(hWndFrm, m_hLastMenu, GetMenuItemCount(m_hLastMenu) - 1, rcPopupBtm)
                        '--- get main menu item dimensions
                        Call GetMenuItemRect(hWndFrm, m_hFormMenu, lI, rcItem)
                        '--- if popup below main menu fix border
                        If rcItem.Bottom + rcPopupBtm.Bottom - rcPopup.Top + 2 * m_lFrameWidth <= GetSystemMetrics(SM_CYSCREEN) Then
                            If Not m_bLastSelMenuRightAlign Then
                                .FillRect 1, 0, rcItem.Right - rcItem.Left - 1, 1, m_clrMenuBack
                            Else
                                .FillRect lWidth - (rcItem.Right - rcItem.Left - 1), 0, lWidth - 1, 1, m_clrMenuBack
                            End If
                        ElseIf rcPopupBtm.Bottom > rcItem.Top Then
                            If Not m_bLastSelMenuRightAlign Then
                                .FillRect 1, lHeight - 1, rcItem.Right - rcItem.Left - 1, lHeight, m_clrMenuBack
                                lHorShadowStart = rcItem.Right - rcItem.Left - 3
                            Else
                                .FillRect lWidth - (rcItem.Right - rcItem.Left - 1), lHeight - 1, lWidth - 1, lHeight, m_clrMenuBack
                                lHorShadowEnd = lHorShadowEnd - (rcItem.Right - rcItem.Left + 3)
                            End If
                        End If
                    End If
                End If
            Next
            '--- shadow
            If m_bConstrainedColors Then
                .FillRect lHorShadowStart + 3, lHeight, lHorShadowEnd, lHeight + 2, vbButtonShadow
                .FillRect lWidth, 3, lWidth + 2, lHeight, vbButtonShadow
            Else
                For lJ = 0 To 2
                    For lI = lHorShadowStart + 3 To lHorShadowEnd
                        .SetPixel lI, lHeight + lJ, pvAlphaBlend(vbBlack, .GetPixel(lI, lHeight + lJ), (&H40 - lJ * (&H40 / 3)) * (IIf(lI <= 6, lI - 2, 4) / 4) * (IIf(lI >= lWidth, lWidth + 3 - lI, 4) / 4))
                    Next
                    For lI = 3 To lHeight - 1
                        .SetPixel lWidth + lJ, lI, pvAlphaBlend(vbBlack, .GetPixel(lWidth + lJ, lI), (&H40 - lJ * (&H40 / 3)) * (IIf(lI <= 6, lI - 2, 4) / 4))
                    Next
                Next
            End If
        End With
        m_cMemDC.Add oMemDC, "#" & hwnd
    End If
QH:
    Set pvGetBackground = oMemDC
End Function

'==============================================================================
' Base class events
'==============================================================================

Private Sub UserControl_Initialize()
    Set m_cMenuSubclass = New Collection
    Set m_cBmps = New Collection
    Set m_cMemDC = New Collection
    Set m_cMenuInfo = New Collection
    Set m_oFont = New StdFont
    If g_oMenuHookImpl Is Nothing Then
        Set g_oMenuHookImpl = New cMenuHook
    End If
    #If DebugMode Then
        DebugInit m_sDebugID, MODULE_NAME
    #End If
End Sub

Private Sub UserControl_Terminate()
    If g_oCurrentMenu Is Me Then
        #If WEAK_REF_CURRENTMENU Then
            CopyMemory VarPtr(g_oCurrentMenu), VarPtr(0), 4
        #Else
            Set g_oCurrentMenu = Nothing
        #End If
    End If
    #If DebugMode Then
        DebugTerm m_sDebugID
    #End If
End Sub

Private Sub UserControl_InitProperties()
    SelectDisabled = DEF_SELECTDISABLED
    BitmapSize = DEF_BITMAPSIZE
    UseSystemFont = DEF_USESYSTEMFONT
    Set Font = DEF_FONT
    Init UserControl.ContainerHwnd
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Dim lIdx            As Long
    Dim vElem           As Variant
    
    On Error Resume Next
    ReDim vElem(0 To 2)
    With PropBag
        SelectDisabled = .ReadProperty("SelectDisabled", DEF_SELECTDISABLED)
        BitmapSize = .ReadProperty("BitmapSize", DEF_BITMAPSIZE)
        For lIdx = 1 To .ReadProperty("BmpCount", 0)
            Set vElem(0) = pvReadPictureProperty(PropBag, "Bmp:" & lIdx, Nothing)
            vElem(1) = .ReadProperty("Mask:" & lIdx, 0)
            vElem(2) = .ReadProperty("Key:" & lIdx, "#" & lIdx)
            m_cBmps.Add vElem, vElem(2)
        Next
        UseSystemFont = .ReadProperty("UseSystemFont", DEF_USESYSTEMFONT)
        Set Font = .ReadProperty("Font", DEF_FONT)
    End With
    Init UserControl.ContainerHwnd
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Dim lIdx            As Long
    
    On Error Resume Next
    With PropBag
        Call .WriteProperty("SelectDisabled", SelectDisabled, DEF_SELECTDISABLED)
        Call .WriteProperty("BitmapSize", BitmapSize, DEF_BITMAPSIZE)
        Call .WriteProperty("BmpCount", m_cBmps.Count)
        For lIdx = 1 To m_cBmps.Count
            Call pvWritePictureProperty(PropBag, "Bmp:" & lIdx, m_cBmps(lIdx)(0), Nothing)
            Call .WriteProperty("Mask:" & lIdx, m_cBmps(lIdx)(1), 0)
            Call .WriteProperty("Key:" & lIdx, m_cBmps(lIdx)(2), "#" & lIdx)
        Next
        Call .WriteProperty("UseSystemFont", UseSystemFont, DEF_USESYSTEMFONT)
        Call .WriteProperty("Font", Font, DEF_FONT)
    End With
End Sub

Private Sub UserControl_Resize()
    Width = ScaleX(32 + m_lEdgeWidth, vbPixels)
    Height = ScaleY(32 + m_lEdgeWidth, vbPixels)
End Sub

'==============================================================================
' ISubclassingSink interface
'==============================================================================

Private Sub ISubclassingSink_Before(bHandled As Boolean, lReturn As Long, hwnd As Long, uMsg As Long, wParam As Long, lParam As Long)
    Static bDelayed  As Boolean
    Dim hDC             As Long
    Dim rc              As RECT
    Dim wp              As WINDOWPOS
    Dim pt              As POINTAPI
    Dim oSub            As cSubclassingThunk
    Dim hMdiChild       As Long
    Dim hPrevMenuWnd    As Long
    Dim mii             As MENUITEMINFO
    Dim sBuffer         As String
    
    If m_oSubclass Is Nothing Or m_oClientSubclass Is Nothing Then
        Exit Sub
    End If
    If hwnd = m_hFormHwnd Or hwnd = m_oClientSubclass.hwnd Then
        Select Case uMsg
        Case WM_INITMENUPOPUP
            '--- first, give WindowList menu a chance to fill visible MDI children
            lReturn = m_oSubclass.CallOrigWndProc(uMsg, wParam, lParam)
            bHandled = True
            '--- then, change type to ownerdrawn
            Call pvInitMenu(wParam, False)
        Case WM_MEASUREITEM
            If wParam = 0 Then
                '--- first, forward to child MDI window
                hMdiChild = pvGetMdiChild
                If hMdiChild <> 0 Then
                    If SendMessage(hMdiChild, uMsg, wParam, lParam) <> 0 Then
                        bHandled = True
                        lReturn = 1
                        Exit Sub
                    End If
                End If
                '--- then, process locally
                If pvMeasureItem(lParam) Then
                    bHandled = True
                    lReturn = 1
                End If
            End If
        Case WM_DRAWITEM
            If wParam = 0 Then
                '--- first, forward to child MDI window
                hMdiChild = pvGetMdiChild
                If hMdiChild <> 0 Then
                    If SendMessage(hMdiChild, uMsg, wParam, lParam) <> 0 Then
                        bHandled = True
                        lReturn = 1
                        Exit Sub
                    End If
                End If
                '--- then, process locally
                If pvDrawItem(lParam) Then
                    bHandled = True
                    lReturn = 1
                End If
            End If
        Case WM_NCCALCSIZE
            If m_hFormMenu = 0 Then
                m_hFormMenu = GetMenu(m_hFormHwnd)
                If m_hFormMenu <> 0 Then
                    '--- set main menu ownerdrawn
                    Call pvInitMenu(m_hFormMenu, True)
                End If
            End If
        Case WM_MENUSELECT
            If m_cMenuSubclass.Count > 0 Then
                hPrevMenuWnd = m_cMenuSubclass(m_cMenuSubclass.Count).hwnd
                '--- win9x: if not positioned yet -> delay message
                If IsWindowVisible(hPrevMenuWnd) = 0 And Not bDelayed Then
                    bDelayed = True
                    PostMessage hwnd, uMsg, wParam, lParam
                    lReturn = 0
                    bHandled = True
                    Exit Sub
                End If
            End If
            bDelayed = False
            m_hLastMenu = GetSubMenu(lParam, wParam And &HFFFF&)
            If m_hLastMenu = 0 Then
                m_hLastMenu = lParam
            End If
            '--- if system menu -> dont position at all
            If (wParam And (MF_SYSMENU * &H10000)) <> 0 Then
                m_hLastSelMenu = 0
            Else
                GetMenuItemRect IIf(lParam = m_hFormMenu, _
                        IIf((wParam And &H2000000) <> 0, _
                                m_hParentHwnd, _
                                m_hFormHwnd), _
                        hPrevMenuWnd), lParam, wParam And &HFFFF&, m_rcLastSelMenu
                '--- get item info
                With mii
                    If OsVersion >= &H40A Then '-