clsskinheader.cls

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

    
End Property

Private Property Get ColumnWidth(ByVal lColumn As Long) As Long
'*/ retrieve a columns length

Dim tHI As HDITEMA

    If Not (m_lHdrHwnd = 0) Then
        With tHI
            .Mask = HDI_WIDTH
            SendMessageA m_lHdrHwnd, HDM_GETITEMA, lColumn, tHI
            ColumnWidth = .cxy
        End With
    End If

End Property

Friend Property Get CustomCursors() As Boolean
    CustomCursors = m_bCustomCursors
End Property

Friend Property Let CustomCursors(ByVal PropVal As Boolean)
    m_bCustomCursors = PropVal
    CreateCursors
End Property

Friend Property Get DragState() As Boolean
    DragState = m_bDragState
End Property

Friend Property Let DragState(ByVal PropVal As Boolean)
    m_bDragState = PropVal
End Property


Friend Property Get ColumnFiltered(ByVal lColumn As Long) As Boolean

On Error GoTo Handler

    ColumnFiltered = m_bColumnFiltered(lColumn)

Handler:
    On Error GoTo 0

End Property

Friend Property Let ColumnFiltered(ByVal lColumn As Long, _
                                   ByVal PropVal As Boolean)

On Error GoTo Handler

    If (lColumn > UBound(m_bColumnFiltered)) Then
        ReDim m_bColumnFiltered(0 To (ColumnCount - 1))
    End If
    m_bColumnFiltered(lColumn) = PropVal

Handler:
    On Error GoTo 0

End Property

Friend Property Get FilterLoaded() As Boolean
'*/ [get]
    FilterLoaded = m_bFilterLoaded
End Property

Friend Property Let FilterLoaded(ByVal PropVal As Boolean)
'*/ [let]
    m_bFilterLoaded = PropVal
End Property

Friend Property Get HeaderActive() As Boolean
    HeaderActive = m_bHeaderActive
End Property

Friend Property Let HeaderActive(ByVal PropVal As Boolean)
    m_bHeaderActive = PropVal
End Property

Friend Property Get HeaderFlat() As Boolean
    HeaderFlat = m_bHeaderFlat
End Property

Friend Property Let HeaderFlat(ByVal PropVal As Boolean)
    m_bHeaderFlat = PropVal
End Property

Friend Property Get HeaderFixedWidth() As Boolean
    HeaderFixedWidth = m_bHeaderFixedWidth
End Property

Friend Property Let HeaderFixedWidth(ByVal PropVal As Boolean)
    m_bHeaderFixedWidth = PropVal
End Property

Friend Property Get HeaderForeColor() As OLE_COLOR
    HeaderForeColor = m_lTextForeColor
End Property

Friend Property Let HeaderForeColor(ByVal PropVal As OLE_COLOR)
    m_lTextForeColor = PropVal
End Property

Friend Property Get HeaderHighLite() As OLE_COLOR
    HeaderHighLite = m_lTextHighLite
End Property

Friend Property Let HeaderHighLite(ByVal PropVal As OLE_COLOR)
    m_lTextHighLite = PropVal
End Property

Friend Property Get HeaderIml() As Long
    HeaderIml = m_lImlHdHndl
End Property

Friend Property Let HeaderIml(ByVal PropVal As Long)
    m_lImlHdHndl = PropVal
End Property

Friend Property Get HeaderLuminence() As Long
    HeaderLuminence = m_lHeaderLuminence
End Property

Friend Property Let HeaderLuminence(ByVal PropVal As Long)
    m_lHeaderLuminence = PropVal
End Property

Friend Property Get HeaderPressed() As OLE_COLOR
    HeaderPressed = m_lTextPressed
End Property

Friend Property Let HeaderPressed(ByVal PropVal As OLE_COLOR)
    m_lTextPressed = PropVal
End Property

Friend Property Get HeaderSizeable() As Boolean
    HeaderSizeable = m_bHeaderSizeable
End Property

Friend Property Let HeaderSizeable(ByVal PropVal As Boolean)
    m_bHeaderSizeable = PropVal
End Property

Friend Property Get HeaderSkinStyle() As Long
    HeaderSkinStyle = m_lHeaderSkinStyle
End Property

Friend Property Let HeaderSkinStyle(ByVal PropVal As Long)
    m_lHeaderSkinStyle = PropVal
End Property

Friend Property Get HeaderTextEffect() As EHdrTextEffect
    HeaderTextEffect = m_lHeaderTextEffect
End Property

Friend Property Let HeaderTextEffect(ByVal PropVal As EHdrTextEffect)
    m_lHeaderTextEffect = PropVal
End Property

Friend Property Get HeaderThemeColor() As Long
    HeaderThemeColor = m_lThemeColor
End Property

Friend Property Let HeaderThemeColor(ByVal PropVal As Long)
    m_lThemeColor = PropVal
End Property

Private Property Get IHeader() As StdPicture
'/* header image
    Set IHeader = m_pHeader
End Property

Private Property Set IHeader(ByVal PropVal As StdPicture)
    Set m_pHeader = PropVal
End Property

Friend Property Get ParentHwnd() As Long
    ParentHwnd = m_lHGHwnd
End Property

Friend Property Let ParentHwnd(ByVal PropVal As Long)
    m_lHGHwnd = PropVal
    If Not (m_lHGHwnd = 0) Then
        m_lHdrHwnd = HeaderHwnd
    End If
End Property

Friend Property Get TipColor() As Long
    TipColor = m_lTipColor
End Property

Friend Property Let TipColor(ByVal PropVal As Long)
    m_lTipColor = PropVal
End Property

Friend Property Get TipDelayTime() As Long
    TipDelayTime = m_lTipDelayTime
End Property

Friend Property Let TipDelayTime(ByVal PropVal As Long)
    m_lTipDelayTime = PropVal
End Property

Friend Property Get TipFont() As StdFont
    TipFont = m_oTipFont
End Property

Friend Property Set TipFont(ByVal PropVal As StdFont)
    m_oTipFont = PropVal
End Property

Friend Property Get TipGradient() As Boolean
    TipGradient = m_bTipGradient
End Property

Friend Property Let TipGradient(ByVal PropVal As Boolean)
    m_bTipGradient = PropVal
End Property

Friend Property Get TipMultiline() As Boolean
    TipMultiline = m_bTipMultiline
End Property

Friend Property Let TipMultiline(ByVal PropVal As Boolean)
    m_bTipMultiline = PropVal
End Property

Friend Property Get TipOffsetColor() As Long
    TipOffsetColor = m_lTipOffsetColor
End Property

Friend Property Let TipOffsetColor(ByVal PropVal As Long)
    m_lTipOffsetColor = PropVal
End Property

Friend Property Get TipPosition() As Long
    TipPosition = m_lTipPosition
End Property

Friend Property Let TipPosition(ByVal PropVal As Long)
    m_lTipPosition = PropVal
End Property

Friend Property Get TipTransparency() As Long
    TipTransparency = m_lTipTransparency
End Property

Friend Property Let TipTransparency(ByVal PropVal As Long)
    m_lTipTransparency = PropVal
End Property

Friend Property Get TipVisibleTime() As Long
    TipVisibleTime = m_lTipVisibleTime
End Property

Friend Property Let TipVisibleTime(ByVal PropVal As Long)
    m_lTipVisibleTime = PropVal
End Property

Friend Property Get TipXPColors() As Boolean
    TipXPColors = m_bTipXPColors
End Property

Friend Property Let TipXPColors(ByVal PropVal As Boolean)
    m_bTipXPColors = PropVal
End Property

Friend Property Get TipHint(ByVal lColumn As Long) As String

On Error GoTo Handler

    TipHint = m_sToolTipHint(lColumn)

Handler:
    On Error GoTo 0

End Property

Friend Property Let TipHint(ByVal lColumn As Long, _
                            ByVal sHint As String)

On Error GoTo Handler

    If (lColumn > UBound(m_sToolTipHint)) Then
        ReDim m_sToolTipHint(0 To ColumnCount - 1)
    End If
    m_sToolTipHint(lColumn) = sHint

Handler:
    On Error GoTo 0

End Property

Friend Property Get ToolTips() As Boolean
    ToolTips = m_bToolTips
End Property

Friend Property Let ToolTips(ByVal PropVal As Boolean)
    
    If PropVal Then
        If (m_cColumnToolTip Is Nothing) Then
            Set m_cColumnToolTip = New clsToolTip
        End If
    Else
        If Not (m_cColumnToolTip Is Nothing) Then
            Set m_cColumnToolTip = Nothing
        End If
    End If
    m_bToolTips = PropVal
    
End Property

Friend Property Get UseHeaderTheme() As Boolean
    UseHeaderTheme = m_bUseHeaderTheme
End Property

Friend Property Let UseHeaderTheme(ByVal PropVal As Boolean)
    m_bUseHeaderTheme = PropVal
End Property

Friend Property Get UseUnicode() As Boolean
    UseUnicode = m_bUseUnicode
End Property

Friend Property Let UseUnicode(ByVal PropVal As Boolean)
    m_bUseUnicode = PropVal
End Property


'> Procedures
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Private Sub BackbufferDestroy()
'/* destroy backbuffer

Dim lCt As Long

On Error GoTo Handler

    For lCt = 0 To 3
        SelectObject m_lHdc(lCt), m_lBmpOld(lCt)
        DeleteObject m_lBmp(lCt)
        DeleteDC m_lHdc(lCt)
        m_lBmpOld(lCt) = 0
        m_lHdc(lCt) = 0
        m_lBmp(lCt) = 0
    Next lCt

Handler:

End Sub

Private Sub BackbufferImages()
'/* store state images

Dim lCt    As Long
Dim lTmpDc As Long

On Error GoTo Handler

    ReDim m_lHdc(3)
    ReDim m_lBmp(3)
    ReDim m_lBmpOld(3)

    lTmpDc = m_cHeaderDc.hdc
    For lCt = 0 To 3
        m_lHdc(lCt) = CreateCompatibleDC(lTmpDc)
        m_lBmp(lCt) = CreateCompatibleBitmap(lTmpDc, m_lHeaderBmpWidth, m_lHeaderBmpHeight)
        m_lBmpOld(lCt) = SelectObject(m_lHdc(lCt), m_lBmp(lCt))
        m_cRender.Blit m_lHdc(lCt), 0, 0, m_lHeaderBmpWidth, m_lHeaderBmpHeight, m_cHeaderDc.hdc, (m_lHeaderBmpWidth * lCt), 0, SRCCOPY
    Next lCt

Handler:

End Sub

Friend Function ColumnFocused() As Long

Dim sX As Single
Dim sY As Single
Dim tP As POINTAPI

    GetCursorPos tP
    ScreenToClient m_lHdrHwnd, tP
    With tP
        sX = .x
        sY = .y + m_tR.Top
    End With
    ColumnFocused = ColumnHitTest(sX, sY)

End Function

Private Function ColumnHitTest(ByVal lX As Long, _
                               ByVal lY As Long, _
                               Optional ByVal bNoOffset As Boolean) As Long

Dim lCt         As Long