clsskinheader.cls

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

Dim sText       As String
Dim tPnt        As POINTAPI
Dim tRText      As RECT
Dim tShft       As RECT

On Error GoTo Handler

    sText = ColumnText(lColumn)
    If LenB(sText) = 0 Then Exit Sub
    lFontOld = SelectObject(lHdc, m_lhFnt)
    SetBkMode lHdc, 1

    '/* pressed
    If lState = 1 Then
        SetTextColor lHdc, m_lTextPressed
        '/* over
    ElseIf lState = 2 Then
        SetTextColor lHdc, m_lTextHighLite
    Else
        SetTextColor lHdc, m_lTextForeColor
    End If

    '/* calculate text ellipses
    CopyRect tShft, tRect
    '/ calculate text size
    If m_bIsNt Then
        GetTextExtentPoint32W lHdc, StrPtr(sText), lstrlenW(StrPtr(sText)), tPnt
    Else
        GetTextExtentPoint32A lHdc, sText, Len(sText), tPnt
    End If
    
    '/* has icon
    bIcon = (ColumnIcon(lColumn) > -1)
    '/* text alignment
    lAlign = ColumnAlign(lColumn)

    LSet tRText = tRect
    lWidth = ColumnWidth(lColumn)
        
    If bIcon Then
        lOffset = (m_lImageWidth + 2)
    End If

    Select Case lAlign
    '/* left
    Case 0
        lOffset = (lOffset + 4)
        With tRText
            .Left = (.Left + lOffset)
        End With
    '/* right
    Case 1
        With tRText
            .Left = (.Left + (lWidth - tPnt.x) - 4)
        End With
    '/* center
    Case 2
        With tRText
            .Left = (.Left + (lWidth - tPnt.x) / 2)
        End With
    '/* left
    Case 3
        lOffset = lOffset + 4
        With tRText
            .Left = (.Left + lOffset)
        End With
    End Select

    With tRText
        '/* minimum x right align
        If (lAlign = 1) Then
            If (.Left + lOffset) < (tRect.Left + lOffset + tPnt.x) Then
                .Left = (tRect.Left + lOffset + 8)
            End If
        '/* minimum x center align
        ElseIf (lAlign = 2) Then
            If (.Left + lOffset) < (tRect.Left + lOffset + tPnt.x) Then
                .Left = (tRect.Left + lOffset) + 8
            End If
        '/* minimum x left align
        Else
            If ((.Left - 2) < tRect.Left) Then
                .Left = (tRect.Left)
            End If
        End If
    End With
    
    '/* draw elipses
    If m_bColumnVerticalText Then
        If ((tPnt.x + lOffset + 14) > lWidth) Then
            If ((tPnt.x + lOffset + 14) < m_lHeaderHeight) Then
                SelectObject lHdc, lFontOld
                lFontOld = 0
                lFontOld = SelectObject(lHdc, m_lvFntDc)
                lFlags = DT_LEFT Or DT_BOTTOM Or DT_SINGLELINE
                OffsetRect tRText, -3, 5
            Else
                tRText.Right = tRText.Right - 4
                lFlags = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS
            End If
        Else
            lFlags = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
        End If
    Else
        With tRText
            '/* test min size
            If ((tPnt.x + lOffset + 14) > lWidth) Then
                .Right = .Right - 4
                lFlags = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS
            Else
                lFlags = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
            End If
        End With
    End If
    
    m_lColumnSpace = tRText.Left + tPnt.x + lOffset

    If m_lHeaderTextEffect = 1 Then
        TextEmbossed lHdc, sText, lFlags, tRText
    ElseIf m_lHeaderTextEffect = 2 Then
        TextEngraved lHdc, sText, lFlags, tRText
    Else
        '/* draw normal text
        If m_bIsNt Then
            DrawTextW lHdc, StrPtr(sText), -1, tRText, lFlags
        Else
            DrawTextA lHdc, sText, -1, tRText, lFlags
        End If
    End If
    
On Error GoTo 0

Handler:
    '/* delete font
    SelectObject lHdc, lFontOld

End Sub

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

Dim bPressed    As Boolean
Dim lhPen       As Long
Dim lhPenOld    As Long
Dim lArwClr     As Long
Dim lRgn        As Long
Dim lBkClr      As Long
Dim lClrOst     As Long
Dim lHzOffset   As Long
Dim lhBrush     As Long
Dim tPnt        As POINTAPI
Dim tRFlt       As RECT

On Error GoTo Handler

    lHzOffset = ((tRect.bottom \ 2) - 7)

    With tRFlt
        .Left = (tRect.Left + (tRect.Right - tRect.Left) - 22)
        .Right = (.Left + 14)
        .Top = lHzOffset
        .bottom = (lHzOffset + 14)
    End With

    '/* fill brush
    lBkClr = GetPixelColor(m_lHdc(0), 4, 4)
    lClrOst = m_cRender.BlendColor(&H484848, lBkClr)
    lArwClr = m_cRender.BlendColor(vbBlue, lBkClr)
    
    With tRFlt
        lRgn = CreateRectRgn((tRect.Left + 2), (.Top - 1), (.Right + 1), (.bottom + 1))
        SelectClipRgn lHdc, lRgn
        If LeftKeyState Then
            If (lColumn = FilterHitTest) Then
                bPressed = True
            End If
        End If
        m_cRender.Gradient lHdc, .Left, .Right - .Left, .Top, .bottom - .Top, lBkClr, lClrOst, Fill_Vertical, bPressed
        
        '/* draw outline
        lhPen = CreatePen(0&, 2&, lArwClr)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, (.Left + 7), (.Top + 2), tPnt
        LineTo lHdc, (.Left + 7), (.Top + 6)
        SelectObject lHdc, lhPenOld
        DeleteObject lhPen
        
        lhPen = CreatePen(0&, 1&, lArwClr)
        lhPenOld = SelectObject(lHdc, lhPen)
        MoveToEx lHdc, (.Left + 3), (.Top + 6), tPnt
        LineTo lHdc, (.Right - 3), (.Top + 6)
        MoveToEx lHdc, (.Left + 4), (.Top + 8), tPnt
        LineTo lHdc, (.Right - 4), (.Top + 8)
        MoveToEx lHdc, (.Left + 5), (.Top + 10), tPnt
        LineTo lHdc, (.Right - 5), (.Top + 10)
    End With
    
    InflateRect tRFlt, 1, 1
    lClrOst = m_cRender.BlendColor(&H0, lBkClr)
    lhBrush = CreateSolidBrush(lClrOst)
    FrameRect lHdc, tRFlt, lhBrush
    
    '/* adjust rect
    With tRect
        .Right = (.Right - 22)
    End With
    
    '/* cleanup
    DeleteObject lhBrush
    SelectClipRgn lHdc, 0&
    DeleteObject lRgn
    SelectObject lHdc, lhPenOld
    DeleteObject lhPen

Handler:
    On Error GoTo 0

End Sub

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

Dim lhPen       As Long
Dim lhPenOld    As Long
Dim lRgn        As Long
Dim lArwClr     As Long
Dim lVtCtr      As Long
Dim lhBrush     As Long
Dim lOldBrush   As Long
Dim tPnt        As POINTAPI

    '/* vertical center
    lVtCtr = (tRect.bottom - tRect.Top) / 2
    '/* arrow fill color
    lArwClr = GetPixelColor(lHdc, 0, 0)
    '/* outline pen
    lhPen = CreatePen(0&, 1&, &H808080)
    lhPenOld = SelectObject(lHdc, lhPen)
    '/* fill brush
    lhBrush = CreateSolidBrush(lArwClr)
    lOldBrush = SelectObject(lHdc, lhBrush)
    '/* track fill path
    BeginPath lHdc
    '/* draw outline
    With tRect
        lRgn = CreateRectRgn(.Left, .Top, .Right, .bottom)
        SelectClipRgn lHdc, lRgn
        If Not m_bSortDescending Then
            MoveToEx lHdc, (.Right - 22), (lVtCtr + 3), tPnt
            LineTo lHdc, (.Right - 15), (lVtCtr - 4)
            LineTo lHdc, (.Right - 8), (lVtCtr + 3)
            LineTo lHdc, (.Right - 22), (lVtCtr + 3)
        Else
            MoveToEx lHdc, (.Right - 22), (lVtCtr - 4), tPnt
            LineTo lHdc, (.Right - 15), (lVtCtr + 3)
            LineTo lHdc, (.Right - 8), (lVtCtr - 4)
            LineTo lHdc, (.Right - 22), (lVtCtr - 4)
        End If
    End With
    '/* finished tracking
    EndPath lHdc
    '/* fill the shape
    StrokeAndFillPath lHdc
    '/* adjust rect
    With tRect
        .Right = (.Right - 22)
    End With
    '/* cleanup
    SelectClipRgn lHdc, 0&
    DeleteObject lRgn
    SelectObject lHdc, lOldBrush
    DeleteObject lhBrush
    SelectObject lHdc, lhPenOld
    DeleteObject lhPen

End Sub

Friend Function FilterHitTest() As Long

Dim lColumn     As Long
Dim lHzOffset   As Long
Dim tPnt        As POINTAPI
Dim tRFlt       As RECT
Dim tRect       As RECT

    FilterHitTest = -1
    GetCursorPos tPnt
    ScreenToClient m_lHdrHwnd, tPnt
    With tPnt
        lColumn = ColumnHitTest(.x, .y, False)
    End With
    If (lColumn = -1) Then
        Exit Function
    End If

    If m_bColumnFiltered(lColumn) Then
        SendMessageA m_lHdrHwnd, HDM_GETITEMRECT, lColumn, tRect
        lHzOffset = ((tRect.bottom \ 2) - 7)
        With tRFlt
            If (lColumn = m_lColumnSorted) Then
                .Left = tRect.Left + ((tRect.Right - tRect.Left) - 44)
                .Right = (tRect.Right - 30)
            Else
                .Left = ((tRect.Left + (tRect.Right - tRect.Left)) - 20)
                .Right = (tRect.Right - 4)
            End If
            .Top = lHzOffset
            .bottom = (lHzOffset + 14)
        End With
    
        With tPnt
            If Not (PtInRect(tRFlt, .x, .y) = 0) Then
                FilterHitTest = lColumn
            End If
        End With
    End If

End Function

Private Function FunctionExported(ByVal sFunction As String, _
                                  ByVal sModule As String) As Boolean
'/* test for library support

Dim lModule As Long

    If m_bIsNt Then
        lModule = GetModuleHandleW(StrPtr(sModule))
        If (lModule = 0) Then
            lModule = LoadLibraryW(StrPtr(sModule))
        End If
    Else
        lModule = GetModuleHandleA(sModule)
        If (lModule = 0) Then
            lModule = LoadLibraryA(sModule)
        End If
    End If
    If Not (lModule = 0) Then
        If GetProcAddress(lModule, StrPtr(sFunction)) Then
            FunctionExported = True
        End If
        FreeLibrary lModule
    End If

End Function

Private Function GetPixelColor(ByVal lHdc As Long, _
                               ByVal lX As Long, _
                               ByVal lY As Long) As Long

    GetPixelColor = GetPixel(lHdc, lX, lY)

End Function

Friend Property Get HeaderDc() As Long

    If m_lHdrHwnd = 0 Then Exit Function
    m_lHeaderDc = GetDC(m_lHdrHwnd)
    ReleaseDC m_lHdrHwnd, m_lHeaderDc
    HeaderDc = m_lHeaderDc
    
End Property

Private Function HeaderHwnd() As Long
'*/ return the column header handle

    If Not (m_lHGHwnd = 0) Then
        HeaderHwnd = SendMessageLongA(m_lHGHwnd, LVM_GETHEADER, 0&, 0&)
    End If
    
End Function

Private Sub HeaderThemeSettings()

    Select Case m_lHeaderLuminence
    Case 0
        m_sngLuminence = 0.3
    Case 1
        m_sngLuminence = 0.6
    Case 2
        m_sngLuminence = 1
    End Select

End Sub

Friend Function HorzSizerHitTest() As Boolean

Dim tPnt    As POINTAPI
Dim tRect   As RECT

    GetCursorPos tPnt
    GetWindowRect m_lHdrHwnd, tRect
    With tRect
        .Top = .bottom - 8
        .bottom