clsfiltermenu.cls

一款Grid表格控件源代码,非常棒.不下你一定会后悔

End Sub

Public Sub DrawMenu()

    CreateSortMenu
    MessageAttach
    Show
    LoadFonts
    CreateControls
    LoadList
    SetFocus m_cList.hWnd
    ActivateList
    m_bShowing = True
    StatusLoop

End Sub

Private Sub DrawText(ByVal lHdc As Long, _
                     ByVal sText As String, _
                     ByRef tRect As RECT)

Dim lFlags As Long

    SetBkMode lHdc, BM_TRANSPARENT
    SetTextColor lHdc, m_lTitleColor
    lFlags = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
    
    If m_bIsNt Then
        sText = sText & Chr$(0)
        DrawTextW lHdc, StrPtr(sText), -1, tRect, lFlags
    Else
        DrawTextA lHdc, sText, -1, tRect, lFlags
    End If
    
End Sub

Private Sub FrameMenu(ByVal lHdc As Long, _
                      ByRef tRect As RECT)

Dim lhPen       As Long
Dim lhPenOld    As Long
Dim tPnt        As POINTAPI

    With tRect
        '/* outer
        lhPen = CreatePen(0, 1, &H808080)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, (.Left - 1), (.bottom - 1), tPnt
        LineTo lHdc, (.Right - 1), (.bottom - 1)
        LineTo lHdc, (.Right - 1), .Top
        SelectObject lHdc, lhPenOld
        DeleteObject lhPen
        '/* inner
        lhPen = CreatePen(0, 1, &H999999)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, .Left, (.bottom - 2), tPnt
        LineTo lHdc, (.Right - 2), (.bottom - 2)
        LineTo lHdc, (.Right - 2), .Top
        LineTo lHdc, .Left, .Top
        LineTo lHdc, .Left, (.bottom - 2)
        SelectObject lHdc, lhPenOld
        DeleteObject lhPen
        .Left = 1
        .Top = 1
        .Right = .Right - 2
        .bottom = .bottom - 2
    End With

End Sub

Private Sub LoadFonts()
        
    DestroyFonts
    If (m_oTextFont Is Nothing) Then
        DefaultFont m_oTextFont, False
    End If
    m_lhTextFont = CreateFont(m_oTextFont, False)
    If (m_oTitleFont Is Nothing) Then
        DefaultFont m_oTitleFont, True
    End If
    m_lhTitleFont = CreateFont(m_oTitleFont, True)
    
End Sub

Private Sub LoadList()

Dim lCt As Long

On Error GoTo Handler

    For lCt = 0 To UBound(m_sListItems)
        m_cList.InsertItem m_sListItems(lCt), lCt
    Next lCt
    
Handler:
    On Error GoTo 0
    
End Sub

Private Sub PaintMenu(ByVal lHdc As Long, _
                     ByRef tRect As RECT)

Dim lhBrush As Long

    lhBrush = CreateSolidBrush(m_lBackColor)
    FillRect lHdc, tRect, lhBrush
    DeleteObject lhBrush

End Sub

Private Sub MsgTimer(ByVal lInterval As Long)
'/* rough timer

Dim lTick   As Long
Dim lCount  As Long

On Error Resume Next

    If Not lInterval = -1 Then
        lTick = GetTickCount()
        lTick = lTick + lInterval
        If lTick > 0& Then
            lTick = ((lTick + &H80000000) + lInterval) + &H80000000
        Else
            lTick = ((lTick - &H80000000) + lInterval) - &H80000000
        End If
        Do
            If Err.Number = 0 Then Exit Sub
            lCount = GetTickCount()
            lCount = lTick - lCount
            If lTick > 0& Then
                lCount = ((lTick + &H80000000) - (lCount - &H80000000))
            Else
                lCount = ((lTick - &H80000000) - (lCount + &H80000000))
            End If
            If IIf((lCount Xor lInterval) > 0&, lCount > lInterval, lCount < 0&) Then
                Exit Sub
            End If
            MsgWaitForMultipleObjects 0&, 0&, 0&, lCount, QS_ALLINPUT
            DoEvents
        Loop
    End If
    
On Error GoTo 0

End Sub

Private Sub StatusLoop()

On Error GoTo Handler

    Do Until (TestActive = True)
        DoEvents
        If m_bDestroy Then
            Exit Do
        End If
        MsgTimer 50
    Loop

On Error GoTo 0

Handler:
    Destroy
    RaiseEvent DestroyMe
    
End Sub

Private Sub RenderMenu(ByVal lHdc As Long, _
                       ByRef tRect As RECT)

Dim lDrawDc     As Long
Dim lFntOld     As Long
Dim lHzOfst     As Long
Dim tRText      As RECT
Dim tRcpy       As RECT

    With m_cFilterMenuDc
        .Width = tRect.Right
        .Height = tRect.bottom
        lDrawDc = .hdc
    End With
    
    CopyRect tRcpy, tRect
    FrameMenu lDrawDc, tRcpy
    
    With tRcpy
        If m_bGradient Then
            lHzOfst = (.bottom / 3)
            m_cRender.Gradient lDrawDc, .Left, .Right, .Top, lHzOfst, m_lBackColor, m_lColorOffset, Fill_Vertical
            m_cRender.Gradient lDrawDc, .Left, .Right, lHzOfst, (.bottom - lHzOfst), m_lBackColor, m_lColorOffset, Fill_Vertical, True
        Else
            PaintMenu lDrawDc, tRect
        End If
    End With

    lFntOld = SelectObject(lDrawDc, m_lhTitleFont)
    CopyRect tRText, tRect
    tRText.bottom = 20
    InflateRect tRText, 0, -2
    DrawText lDrawDc, m_sTitle, tRText
    SelectObject lDrawDc, lFntOld
    
    With tRect
        If (m_lTransparency = -1) Then
            m_cRender.Blit lHdc, 0, 0, .Right, .bottom, lDrawDc, 0, 0, SRCCOPY
        Else
            m_cRender.AlphaBlit lHdc, 0, 0, .Right, .bottom, lDrawDc, 0, 0, .Right, .bottom, m_lTransparency
        End If
    End With
    
    SelectObject lDrawDc, lFntOld
    
End Sub

Public Sub SetPosition(ByVal lX As Long, _
                       ByVal lY As Long)
    
    If (m_lFilterMenuHwnd = 0) Then Exit Sub
    SetWindowPos m_lFilterMenuHwnd, HWND_TOP, lX, lY, 0&, 0&, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_NOOWNERZORDER
    
End Sub

Public Sub SetSize(ByVal lWidth As Long, _
                   ByVal lHeight As Long)

    If (m_lFilterMenuHwnd = 0) Then Exit Sub
    SetWindowPos m_lFilterMenuHwnd, HWND_TOP, 0&, 0&, lWidth, lHeight, SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_NOOWNERZORDER

End Sub

Private Sub Show()
    
    If Not (m_lFilterMenuHwnd = 0) Then
        With m_tRWnd
            SetWindowPos m_lFilterMenuHwnd, 0&, .Left, .Top, .Right, .bottom, SWP_NOOWNERZORDER Or SWP_SHOWWINDOW Or SWP_NOACTIVATE
        End With
    End If
    
End Sub

Public Sub ShowMenu(ByVal lHwnd As Long, _
                    ByVal sTitle As String, _
                    ByVal lX As Long, _
                    ByVal lY As Long, _
                    ByVal lWidth As Long, _
                    ByVal lHeight As Long)

    If Not (lHwnd = 0) Then
        m_lCtrlHwnd = lHwnd
        Title = sTitle
    End If
    
    With m_tRWnd
        .bottom = lHeight
        .Left = lX
        .Right = lWidth
        .Top = lY
    End With
    
    If m_bIsActive Then
        Destroy
    End If
    DrawMenu
    
End Sub


'> Subclass
'>>>>>>>>>>>>>>>>
Private Sub MessageAttach()

    If Not m_SBSubclass Is Nothing Then
        If Not m_bIsActive Then
            With m_SBSubclass
                .Subclass m_lParentHwnd, Me
                .AddMessage m_lParentHwnd, WM_DRAWITEM, MSG_BEFORE
            End With
            m_bIsActive = True
        End If
    End If
    
End Sub

Private Sub MessageDetach()

    If Not m_SBSubclass Is Nothing Then
        If m_bIsActive Then
            With m_SBSubclass
                .DeleteMessage m_lParentHwnd, WM_DRAWITEM, MSG_BEFORE
                .UnSubclass m_lParentHwnd
            End With
            m_bIsActive = False
        End If
    End If
    
End Sub

Private Function TestActive() As Boolean

Dim tPnt    As POINTAPI
Dim tRect   As RECT

    GetCursorPos tPnt
    GetWindowRect m_lFilterMenuHwnd, tRect
    If (PtInRect(tRect, tPnt.x, tPnt.y) = 0) Then
        m_lSafeTimer = m_lSafeTimer + 1
    Else
        m_lSafeTimer = 0
    End If
    If (m_lSafeTimer > 10) Then
        TestActive = True
    End If
    
End Function

Private Sub GXISubclass_WndProc(ByVal bBefore As Boolean, _
                                bHandled As Boolean, _
                                lReturn As Long, _
                                ByVal lHwnd As Long, _
                                ByVal uMsg As eMsg, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long, _
                                lParamUser As Long)

Dim tDIstc As DRAWITEMSTRUCT

    Select Case uMsg
    Case WM_DRAWITEM
        CopyMemory tDIstc, ByVal lParam, LenB(tDIstc)
        With tDIstc
            RenderMenu .hdc, .rcItem
        End With
    End Select
    
End Sub

'> Cleanup
'>>>>>>>>>>>>>>>>
Private Sub DestroyMenu()

    If Not (m_lFilterMenuHwnd = 0) Then
        MessageDetach
        DestroyWindow m_lFilterMenuHwnd
        m_bShowing = False
    End If

End Sub

Public Sub Destroy()

    If Not (m_lFilterMenuHwnd = 0) Then
        MessageDetach
        DestroyFonts
        If Not m_cList Is Nothing Then Set m_cList = Nothing
        If Not m_cFilter Is Nothing Then Set m_cFilter = Nothing
        If Not m_cClose Is Nothing Then Set m_cClose = Nothing
        If Not m_cExact Is Nothing Then Set m_cExact = Nothing
        If Not m_oTextFont Is Nothing Then Set m_oTextFont = Nothing
        If Not m_oTitleFont Is Nothing Then Set m_oTitleFont = Nothing
        If Not m_cRender Is Nothing Then Set m_cRender = Nothing
        If Not m_cFilterMenuDc Is Nothing Then Set m_cFilterMenuDc = Nothing
        If Not m_SBSubclass Is Nothing Then Set m_SBSubclass = Nothing
        DestroyMenu
        m_lFilterMenuHwnd = 0
    End If

End Sub

Private Sub Class_Terminate()
    Destroy
End Sub