ctxhookmenu.ctl

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

            If wParam Then
                CopyMemory lParam, VarPtr(rc), Len(rc)
                CopyMemory lParam + 2 * Len(rc), VarPtr(rc), Len(rc)
            End If
            bHandled = True
            lReturn = 0
          Case WM_NCPAINT
            '-- Ammended To Take Care Of The Scroll Effect
            '-- When Menu Animations Are Active.
            '-- Gary Noble (Phantom Man - PSC)
            If Not m_blnFirstMenuInitialize Then
                GetWindowRect hwnd, rc
                hDC = GetWindowDC(hwnd)
                ExcludeClipRect hDC, 1, 2, rc.Right - rc.Left - 6, rc.Bottom - rc.Top - 4
                pvGetBackground(hwnd).BitBlt hDC
                Call ReleaseDC(hwnd, hDC)
                bHandled = True
                lReturn = 0
              Else
                bHandled = False
                lReturn = 0
            End If
          Case WM_WINDOWPOSCHANGING
            CopyMemory VarPtr(wp), lParam, Len(wp)
            m_blnAutoColumnTop = False
            m_blnPopupLeftMost = False
            m_blnPopupAbove = False

            If (wp.Flags And SWP_NOMOVE) = 0 Then
                If m_hLastSelMenu <> 0 Then
                    GetWindowRect hwnd, rc

                    '-- Added Gary Noble
                    '-- Moves The Menu To The Right
                    '-- To Take Care Of The Painting When A Popup Menu Is Unloaded
                    'If Me.DisplayShadow Then wp.X = wp.X + 4

                    If m_hLastSelMenu = m_hFormMenu Then

                        '-- Reposition The Menu
                        '-- Gary Noble 2003
                        '--corrected next line NR
                        '   If Me.DisplayShadow Then wp.X = wp.X - 4
                        If m_rcLastSelMenu.Left - 5 > wp.x Then
                            m_blnPopupLeftMost = True
                            'lSpecialLineOffset = rc.Left + m_rcLastSelMenu.Left - wp.X
                            '--corrected NR
                            lSpecialLineOffset = m_rcLastSelMenu.Left - wp.x
                          ElseIf m_rcLastSelMenu.Left < 0 Then
                            wp.x = m_rcLastSelMenu.Left
                            'lSpecialLineOffset = (m_rcLastSelMenu.Left + rc.Left + wp.X) - m_rcLastSelMenu.Left
                            lSpecialLineOffset = 0
                          ElseIf wp.x > rc.Left + m_rcLastSelMenu.Left - 1 Then
                            lSpecialLineOffset = m_rcLastSelMenu.Left + rc.Left - wp.x
                          Else
                            lSpecialLineOffset = 0
                        End If

                        If m_rcLastSelMenu.Right > (Screen.Width / Screen.TwipsPerPixelX) Then
                            '   wp.X = m_rcLastSelMenu.Left
                            lSpecialLineOffset = m_rcLastSelMenu.Left - wp.x
                        End If

                        If wp.y > m_rcLastSelMenu.Bottom - 1 Then
                            wp.y = m_rcLastSelMenu.Bottom - 1
                            m_blnPopupAbove = True
                          Else
                            m_blnPopupAbove = True
                            If AutoColumn > 0 Then
                                m_blnAutoColumnTop = True
                              Else
                                m_blnAutoColumnTop = False
                            End If

                            wp.y = m_rcLastSelMenu.Top - (rc.Bottom - rc.Top - 4)

                        End If

                        If m_bLastSelMenuRightAlign Then
                            wp.x = wp.x + 5
                        End If
                      Else
                        If (rc.Bottom - rc.Top) + m_rcLastSelMenu.Top < GetSystemMetrics(SM_CYSCREEN) Then
                            wp.y = m_rcLastSelMenu.Top
                          Else

                            wp.y = GetSystemMetrics(SM_CYSCREEN) - (rc.Bottom - rc.Top)
                        End If
                        If m_bLastSelMenuRightAlign Then
                            wp.x = wp.x + 3
                        End If
                    End If
                    If wp.y < 0 Then
                        wp.y = 0
                    End If
                    CopyMemory lParam, VarPtr(wp), Len(wp)
                End If

                m_ptLast.x = wp.x
                m_ptLast.y = wp.y
            End If
          Case WM_PRINT
            m_blnFirstMenuInitialize = True
            pvGetBackground(hwnd).BitBlt wParam
            GetViewportOrgEx wParam, VarPtr(pt)
            SetViewportOrgEx wParam, pt.x + 1, pt.y + 2, 0
            Set oSub = m_cMenuSubclass("#" & hwnd)
            lReturn = oSub.CallOrigWndProc(WM_PRINTCLIENT, wParam, lParam)
            SetViewportOrgEx wParam, pt.x, pt.y, 0
            '--- winxp: remove clipping because the dc in wParam will be reused
            '---   for WM_PRINT-ing all menus systemwide!
            SelectClipRgn wParam, 0
            bHandled = True
          Case WM_SHOWWINDOW, WM_DESTROY
            On Error Resume Next
                If (wParam And &HFFFF&) = 0 Or uMsg = WM_DESTROY Then
                    '--- call original
                    Set oSub = m_cMenuSubclass("#" & hwnd)
                    lReturn = oSub.CallOrigWndProc(uMsg, wParam, lParam)
                    bHandled = True
                    '--- win9x and NT only: restore window styles
                    If Not IsNT Or OsVersion <= &H400 Then
                        SetWindowLong hwnd, GWL_STYLE, oSub.Tag(0) Or WS_VISIBLE Or WS_BORDER
                        SetWindowLong hwnd, GWL_EXSTYLE, oSub.Tag(1) Or WS_EX_DLGMODALFRAME Or WS_EX_WINDOWEDGE
                    End If
                    '--- remove subclasser (effectively unsubclassing)
                    m_cMenuSubclass.Remove "#" & hwnd
                    '-- Raise Highlight Event To Display Nothing As The Menu is Being Destroyed
                    RaiseEvent Highlight("")

                    ' If OsVersion = VER_PLATFORM_WIN2000 Then SendMessage lsHwnd, WM_NCPAINT, wParam, lParam
                    '--- remove cache (free resources)
                    m_cMemDC.Remove "#" & hwnd
                End If
            End Select
        End If

    On Error GoTo 0

End Sub

Private Sub m_oFont_FontChanged(ByVal PropertyName As String)

    pvGetMeasures

End Sub

Public Property Get MenuDrawStyle() As UcsDrawStyle

    MenuDrawStyle = m_MenuDrawStyle

End Property

Public Property Let MenuDrawStyle(ByVal New_MenuDrawStyle As UcsDrawStyle)

    m_MenuDrawStyle = New_MenuDrawStyle
    PropertyChanged "MenuDrawStyle"

End Property

Private Property Get OsVersion() As Long

  Static lVersion     As Long
  Dim uVer            As OSVERSIONINFO

    If lVersion = 0 Then
        uVer.dwOSVersionInfoSize = Len(uVer)
        If GetVersionEx(uVer) Then
            lVersion = uVer.dwMajorVersion * &H100 + uVer.dwMinorVersion
        End If
    End If
    OsVersion = lVersion

End Property

Private Function pvAlphaBlend(ByVal clrFirst As Long, ByVal clrSecond As Long, ByVal lAlpha As Long) As Long

  Dim clrFore         As UcsRgbQuad
  Dim clrBack         As UcsRgbQuad

    OleTranslateColor clrFirst, 0, VarPtr(clrFore)
    OleTranslateColor clrSecond, 0, VarPtr(clrBack)
    With clrFore
        .R = (.R * lAlpha + clrBack.R * (255 - lAlpha)) / 255
        .G = (.G * lAlpha + clrBack.G * (255 - lAlpha)) / 255
        .B = (.B * lAlpha + clrBack.B * (255 - lAlpha)) / 255
    End With
    CopyMemory VarPtr(pvAlphaBlend), VarPtr(clrFore), 4

End Function

'-- For Win2000 Only
'-- Drawing From The PVGetBackGround Seemed To Cause A Few Problems
'-- In Win2000 - This Is the Work Around At Last
'-- Gary Noble - 12-11-2003
Private Sub pvDoWin2000Borders(oMemDC As cMemDC, rc As RECT, rcItem As RECT, rcPopup As RECT, rcPopupBtm As RECT, m_bLastSelMenuRightAlign As Boolean, lWidth As Long, lHeight As Long, lHorShadowStart As Long, lHorShadowEnd As Long)

    With oMemDC
        If m_blnAutoColumnTop Then
            If AutoColumn = 0 Then
                .FillRect lSpecialLineOffset, lHeight - 1, lSpecialLineOffset - rcItem.Right - rcItem.Left - 1, lHeight, m_clrMenuBack
                lHorShadowStart = lSpecialLineOffset + rcItem.Right - rcItem.Left - 2
              Else
                .FillRect lSpecialLineOffset + 1, lHeight - 1, lSpecialLineOffset + rcItem.Right - rcItem.Left - 1, lHeight, m_clrMenuBack
                lHorShadowStart = rcItem.Right - rcItem.Left - 2
            End If
          Else
            If rcItem.Bottom + rcPopupBtm.Bottom - rcPopup.Top + 2 * m_lFrameWidth <= GetSystemMetrics(SM_CYSCREEN) Then
                If Not m_bLastSelMenuRightAlign Then
                    .FillRect lSpecialLineOffset + 1, 0, lSpecialLineOffset + IIf(AutoColumn > 0, 0, 0) + rcItem.Right - rcItem.Left - 1, 1, m_clrMenuBack
                  Else
                    .FillRect lWidth - (rcItem.Right - rcItem.Left - 1), 0, lSpecialLineOffset - 1 + lWidth - 1, 1, m_clrMenuBack
                End If
                lHorShadowStart = 0
              ElseIf rcPopupBtm.Bottom > rcItem.Top Then
                If Not m_bLastSelMenuRightAlign Then
                    .FillRect lSpecialLineOffset + 1, lHeight - 1, lSpecialLineOffset + rcItem.Right - rcItem.Left - 1, lHeight, m_clrMenuBack
                    lHorShadowStart = rcItem.Right - rcItem.Left - 2
                  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 With

End Sub

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
  Dim bCustom         As Boolean
  Dim bExclude        As Boolean
  Dim oldColor        As OLE_COLOR
  Dim oFntOrig        As StdFont
  Dim oFntNew         As StdFont
  Dim oldColorHoverBack As OLE_COLOR
  Dim oldColorHoverBorder As OLE_COLOR

    bCustom = IIf(Me.DrawStyle = MS_自定义, False, True)

    '--- 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)
        '--- Fire Our Custom Item Draw Event

        '--- if not found -> bail out immediately
        If dis.itemID <> lId Or dis.hwndItem <> hMenu Then
            RaiseEvent Highlight("")
            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
            oldColor = m_clrMenuFore

            If Not UseSystemFont Then
                '--- merge fonts
  Dim oFnt As StdFont
                Set oFnt = .Font
                oFnt.Name = Font.Name