clsfiltermenu.cls

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

    m_lTitleColor = &HFEFEFE
    m_lColorOffset = &HCACACA
    Set m_cList = New clsODControl
    Set m_cFilter = New clsODControl
    Set m_cClose = New clsODControl
    Set m_cExact = New clsODControl
    ReDim m_sListItems(0)
    m_lTransparency = -1
    m_lControlColor = -1

End Sub

Private Sub m_cClose_Click()
    m_bDestroy = True
End Sub

Private Sub m_cFilter_Click()

Dim lCt As Long

    With m_cList
        For lCt = 0 To (.ListCount - 1)
            If .SelectedItem(lCt) Then
                RaiseEvent FilterIndex(lCt)
            End If
        Next lCt
    End With
    
End Sub

Public Property Get BackColor() As Long
    BackColor = m_lBackColor
End Property

Public Property Let BackColor(ByVal PropVal As Long)
    If m_bXPColors Then
        m_lBackColor = m_cRender.XPShift(PropVal)
    Else
        m_lBackColor = PropVal
    End If
End Property

Public Property Get Checked() As Boolean
    Checked = m_cExact.Checked
End Property

Public Property Get ColorOffset() As Long
    ColorOffset = m_lColorOffset
End Property

Public Property Let ColorOffset(ByVal PropVal As Long)
    If m_bXPColors Then
        m_lColorOffset = m_cRender.XPShift(PropVal)
    Else
        m_lColorOffset = PropVal
    End If
End Property

Public Property Get ControlColor() As Long
    ControlColor = m_lControlColor
End Property

Public Property Let ControlColor(ByVal PropVal As Long)
    m_lControlColor = PropVal
End Property

Public Property Get ForeColor() As Long
    ForeColor = m_lForeColor
End Property

Public Property Let ForeColor(ByVal PropVal As Long)
    m_lForeColor = PropVal
End Property

Public Property Get Gradient() As Boolean
    Gradient = m_bGradient
End Property

Public Property Let Gradient(ByVal PropVal As Boolean)
    m_bGradient = PropVal
End Property

Public Property Get Height() As Long
    Height = m_lHeight
End Property

Public Property Let Height(ByVal PropVal As Long)
    m_lHeight = PropVal
End Property

Public Property Get hWnd() As Long
    hWnd = m_lFilterMenuHwnd
End Property

Public Property Get Position() As EFSPosition
    Position = m_lPosition
End Property

Public Property Let Position(ByVal PropVal As EFSPosition)
    m_lPosition = PropVal
End Property

Public Property Get Shadow() As Boolean
    Shadow = m_bShadow
End Property

Public Property Let Shadow(ByVal PropVal As Boolean)
    m_bShadow = PropVal
End Property

Public Property Get Title() As String
    Title = m_sTitle
End Property

Public Property Let Title(ByVal PropVal As String)
    m_sTitle = PropVal
End Property

Public Property Get TitleColor() As Long
    TitleColor = m_lTitleColor
End Property

Public Property Let TitleColor(ByVal PropVal As Long)
    m_lTitleColor = PropVal
End Property

Public Property Get TextFont() As StdFont
    Set TextFont = m_oTextFont
End Property

Public Property Set TextFont(ByVal PropVal As StdFont)
    Set m_oTextFont = PropVal
End Property

Public Property Get TitleFont() As StdFont
    Set TitleFont = m_oTitleFont
End Property

Public Property Set TitleFont(ByVal PropVal As StdFont)
    Set m_oTitleFont = PropVal
End Property

Public Property Get ThemeIndex() As Long
    ThemeIndex = m_lThemeIndex
End Property

Public Property Let ThemeIndex(ByVal PropVal As Long)
    m_lThemeIndex = PropVal
End Property

Public Property Get Transparency() As Long
    Transparency = m_lTransparency
End Property

Public Property Let Transparency(ByVal PropVal As Long)

    If (PropVal < 70) Then
        PropVal = 70
    ElseIf (PropVal > 255) Then
        PropVal = 254
    End If
    m_lTransparency = PropVal
    
End Property

Public Property Get Transition() As EFTTransition
    Transition = m_lTransition
End Property

Public Property Let Transition(ByVal PropVal As EFTTransition)
    m_lTransition = PropVal
End Property

Public Property Get Width() As Long
    Width = m_lWidth
End Property

Public Property Let Width(ByVal PropVal As Long)
    m_lWidth = PropVal
End Property

Public Property Get XPColors() As Boolean
    XPColors = m_bXPColors
End Property

Public Property Let XPColors(ByVal PropVal As Boolean)
    m_bXPColors = PropVal
End Property


Private Sub ActivateList()

Dim tPcd    As POINTAPI
Dim tRect   As RECT

    GetWindowRect m_cList.hWnd, tRect
    CopyMemory tPcd, tRect, Len(tPcd)
    ScreenToClient m_lFilterMenuHwnd, tPcd
    
    mouse_event MOUSEEVENTF_MOVE, (tPcd.x + 7), (tPcd.y + 7), 0&, GetMessageExtraInfo()
    mouse_event MOUSEEVENTF_LEFTDOWN, 0&, 0&, 0&, GetMessageExtraInfo()
    mouse_event MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, GetMessageExtraInfo()
    
End Sub

Public Sub AddItem(ByVal lIndex As Long, _
                   ByVal sItem As String)

On Error GoTo Handler

    If UBound(m_sListItems) < lIndex Then
        ReDim Preserve m_sListItems(0 To lIndex)
    End If
    m_sListItems(lIndex) = sItem

Handler:

End Sub

Private Function CompatabilityCheck() As Boolean

Dim tVer As VERSIONINFO

    tVer.dwOSVersionInfoSize = Len(tVer)
    GetVersionEx tVer
    If tVer.dwMajorVersion >= 5 Then
        CompatabilityCheck = True
    End If

End Function

Private Sub CreateControls()

    With m_cList
        .BackColor = m_lBackColor
        .ForeColor = m_lForeColor
        .Create m_lFilterMenuHwnd, 5, 19, (m_tRWnd.Right - 12), (m_tRWnd.bottom - 49), ecsListBox
        .HFont = m_lhTextFont
        .BorderStyle ecbsThin
    End With
    
    With m_cClose
        If Not (m_lControlColor = -1) Then
            .ThemeColor = m_lBackColor
        End If
        .Name = "Close"
        .ForeColor = m_lForeColor
        .Create m_lFilterMenuHwnd, (m_tRWnd.Right - 19), 4, 12, 12, ecsCommandButton
        .HFont = m_lhTextFont
        .Text = "-"
    End With
        
    With m_cExact
        If Not (m_lControlColor = -1) Then
            .ThemeColor = m_lBackColor
        End If
        .BackColor = m_lBackColor
        .ForeColor = m_lForeColor
        .Name = "Exact"
        .Create m_lFilterMenuHwnd, 5, (m_tRWnd.bottom - 25), 50, 14, ecsCheckBox
        .HFont = m_lhTextFont
        .AutoBackColor = True
        .Text = "Exact"
    End With
    
    With m_cFilter
        If Not (m_lControlColor = -1) Then
            .ThemeColor = m_lBackColor
        End If
        .BackColor = m_lBackColor
        .ForeColor = m_lForeColor
        .HiliteColor = &HDCDCDC
        .Name = "Filter"
        .Create m_lFilterMenuHwnd, (m_tRWnd.Right - 45), (m_tRWnd.bottom - 25), 40, 18, ecsCommandButton
        .HFont = m_lhTextFont
        .Text = "Filter"
    End With

End Sub

Private Function CreateFont(ByVal oFont As StdFont, _
                            Optional ByVal bTitle As Boolean) As Long
'*/ change list font

Dim lChar   As Long
Dim lHdc    As Long
Dim tLF     As LOGFONT

On Error GoTo Handler
    
    lHdc = CreateDc("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    With tLF
        For lChar = 1 To Len(oFont.Name)
            .lfFaceName(lChar - 1) = CByte(Asc(Mid$(oFont.Name, lChar, 1)))
        Next lChar
        If bTitle Then
            oFont.Bold = True
            oFont.Size = 9
        End If
        .lfHeight = -MulDiv(oFont.Size, GetDeviceCaps(lHdc, LOGPIXELSY), 72)
        .lfItalic = oFont.Italic
        .lfWeight = IIf(oFont.Bold, FW_BOLD, FW_NORMAL)
        .lfUnderline = oFont.Underline
        .lfStrikeOut = oFont.Strikethrough
        .lfCharSet = 4
        .lfQuality = LF_ANTIALIASED_QUALITY
    End With
    DeleteDC lHdc
    
    If m_bIsNt Then
        CreateFont = CreateFontIndirectW(tLF)
    Else
        CreateFont = CreateFontIndirectA(tLF)
    End If

On Error GoTo 0
Exit Function

Handler:

End Function

Private Sub CreateSortMenu()

Dim bOnDesktop  As Boolean
Dim lTTStyle    As Long

    m_lParentHwnd = GetParent(m_lCtrlHwnd)
    bOnDesktop = (m_lParentHwnd = GetDesktopWindow())
    lTTStyle = WS_CHILD Or WS_CLIPCHILDREN Or WS_CLIPSIBLINGS Or WS_TABSTOP Or SS_OWNERDRAW

    If m_bIsNt Then
        m_lFilterMenuHwnd = CreateWindowExW(-bOnDesktop * WS_EX_TOOLWINDOW, StrPtr("static"), StrPtr(""), lTTStyle, _
            0&, 0&, 0&, 0&, m_lParentHwnd, 0&, App.hInstance, ByVal 0&)
    Else
        m_lFilterMenuHwnd = CreateWindowExA(-bOnDesktop * WS_EX_TOOLWINDOW, "static", "", lTTStyle, _
            0&, 0&, 0&, 0&, m_lParentHwnd, 0&, App.hInstance, ByVal 0&)
    End If
    
End Sub

Private Sub DefaultFont(ByRef oFont As StdFont, _
                        Optional ByVal bTitle As Boolean)

    Set oFont = New StdFont
    With oFont
        .Charset = 3
        .Name = "MS Sans Serif"
        .Weight = 400
        .Size = 8
        If bTitle Then
            .Bold = True
        End If
    End With

End Sub

Private Sub DestroyFonts()

    If Not (m_lhTitleFont = 0) Then
        DeleteObject m_lhTitleFont
        m_lhTitleFont = 0
    End If
    If Not (m_oTitleFont Is Nothing) Then
        Set m_oTitleFont = Nothing
    End If
    If Not (m_lhTextFont = 0) Then
        DeleteObject m_lhTextFont
        m_lhTitleFont = 0
    End If
    If Not (m_oTextFont Is Nothing) Then
        Set m_oTextFont = Nothing
    End If