clsskinheader.cls

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

Dim lIndex      As Long
Dim tRect       As RECT

On Error GoTo Handler

    lIndex = -1
    For lCt = 0 To (ColumnCount - 1)
        If m_bIsNt Then
            SendMessageW m_lHdrHwnd, HDM_GETITEMRECT, lCt, tRect
        Else
            SendMessageA m_lHdrHwnd, HDM_GETITEMRECT, lCt, tRect
        End If
        If Not bNoOffset Then
            InflateRect tRect, -3, 0
        End If
        If m_bHeaderSizeable Then
            With tRect
                .bottom = .bottom - 6
            End With
        End If
        If Not (PtInRect(tRect, lX, lY) = 0) Then
            lIndex = lCt
            Exit For
        End If
    Next lCt
    ColumnHitTest = lIndex

Handler:
    On Error GoTo 0

End Function

Private Sub ColumnRender(ByVal lOffset As Long, _
                         ByVal lColumn As Long)

'/* render columns

Dim lCt         As Long
Dim lDrawDc     As Long
Dim lBmp        As Long
Dim lBmpOld     As Long
Dim lX          As Long
Dim lHdc        As Long
Dim lHdrClt     As Long
Dim tHdr        As RECT
Dim tTemp       As RECT
Dim tRect       As RECT

    '/* get the dc
    lHdc = GetDC(m_lHdrHwnd)
    lDrawDc = CreateCompatibleDC(lHdc)
    '/* get coordinates
    GetClientRect m_lHdrHwnd, tRect
    GetClientRect m_lHGHwnd, tHdr

    '/* max is now 5x client width
    With tHdr
        lBmp = CreateCompatibleBitmap(lHdc, .Right * 2, tRect.bottom)
    End With
    
    lBmpOld = SelectObject(lDrawDc, lBmp)

    lX = 0
    For lCt = 0 To (ColumnCount - 1)
        If m_bIsNt Then
            SendMessageW m_lHdrHwnd, HDM_GETITEMRECT, lCt, tTemp
        Else
            SendMessageA m_lHdrHwnd, HDM_GETITEMRECT, lCt, tTemp
        End If
        With tTemp
            If (lCt = lColumn) Then
                lX = lOffset
            Else
                lX = 0
            End If
            If m_bDragState Then
                lX = 0
            End If
            m_lHeaderHeight = (.bottom - .Top)
            '/* left side
            m_cRender.Stretch lDrawDc, .Left, 3, 3, (.bottom - 6), m_lHdc(lX), 0, 3, 3, (m_lHeaderBmpHeight - 6), SRCCOPY
            '/* right side
            m_cRender.Stretch lDrawDc, (.Right - 3), (.Top + 3), 3, (.bottom - 6), m_lHdc(lX), (m_lHeaderBmpWidth - 3), 3, 3, (m_lHeaderBmpHeight - 6), SRCCOPY
            '/* top left corner
            m_cRender.Stretch lDrawDc, .Left, 0, 3, 3, m_lHdc(lX), 0, 0, 3, 3, SRCCOPY
            '/* top
            m_cRender.Stretch lDrawDc, (.Left + 3), 0, ((.Right - .Left) - 3), 3, m_lHdc(lX), 3, 0, (m_lHeaderBmpWidth - 3), 3, SRCCOPY
            '/* bottom
            m_cRender.Stretch lDrawDc, (.Left + 3), (.bottom - 3), ((.Right - .Left) - 3), 3, m_lHdc(lX), 3, (m_lHeaderBmpHeight - 3), (m_lHeaderBmpWidth - 3), 3, SRCCOPY
            '/* bottom left corner
            m_cRender.Stretch lDrawDc, .Left, (.bottom - 3), 3, 3, m_lHdc(lX), 0, (m_lHeaderBmpHeight - 3), 3, 3, SRCCOPY
            '/* center
            m_cRender.Stretch lDrawDc, (.Left + 3), 3, ((.Right - .Left) - 6), (.bottom - 6), m_lHdc(lX), 3, 3, (m_lHeaderBmpWidth - 6), (m_lHeaderBmpHeight - 6), SRCCOPY
        End With
        DrawColumnIcon lCt, lDrawDc, tTemp
        DrawColumnText lDrawDc, lCt, lX, tTemp
    Next lCt

    '/* draw header end piece
    If m_bIsNt Then
        SendMessageW m_lHdrHwnd, HDM_GETITEMRECT, ColumnAtIndex(ColumnCount - 1), tTemp
    Else
        SendMessageA m_lHdrHwnd, HDM_GETITEMRECT, ColumnAtIndex(ColumnCount - 1), tTemp
    End If
    lHdrClt = tTemp.Right
    
    With tRect
        '/* left side
        m_cRender.Stretch lDrawDc, lHdrClt, 3, 3, (.bottom - 6), m_lHdc(3), 0, 3, 3, (m_lHeaderBmpHeight - 6), SRCCOPY
        '/* right side
        m_cRender.Stretch lDrawDc, (.Right - 3), (.Top + 3), 3, (.bottom - 6), m_lHdc(3), (m_lHeaderBmpWidth - 3), 3, 3, (m_lHeaderBmpHeight - 6), SRCCOPY
        '/* top left corner
        m_cRender.Stretch lDrawDc, lHdrClt, 0, 3, 3, m_lHdc(0), 0, 0, 3, 3, SRCCOPY
        '/* top
        m_cRender.Stretch lDrawDc, (lHdrClt + 3), 0, (.Right - 3), 3, m_lHdc(3), 3, 0, (m_lHeaderBmpWidth - 3), 3, SRCCOPY
        '/* bottom
        m_cRender.Stretch lDrawDc, (lHdrClt + 3), (.bottom - 3), (.Right - 3), 3, m_lHdc(3), 3, (m_lHeaderBmpHeight - 3), (m_lHeaderBmpWidth - 3), 3, SRCCOPY
        '/* bottom left corner
        m_cRender.Stretch lDrawDc, lHdrClt, (.bottom - 3), 3, 3, m_lHdc(3), 0, (m_lHeaderBmpHeight - 3), 3, 3, SRCCOPY
        '/* center
        m_cRender.Stretch lDrawDc, (lHdrClt + 3), 3, (.Right - 6), (.bottom - 6), m_lHdc(3), 3, 3, (m_lHeaderBmpWidth - 6), (m_lHeaderBmpHeight - 6), SRCCOPY
        '/* draw to screen
        m_cRender.Blit lHdc, .Left, .Top, .Right, .bottom, lDrawDc, 0, 0, SRCCOPY
    End With

    SelectObject lDrawDc, lBmpOld
    DeleteObject lBmp
    lBmpOld = 0
    DeleteDC lDrawDc
    ReleaseDC m_lHdrHwnd, lHdc

End Sub

Private Sub CreateCursors()

On Error GoTo Handler

    DestroyCursors
    If m_bCustomCursors Then
        '/* why does this work in c++, but not in vb? poor vb6 res implementation..
        'm_lhNormalCursor = LoadCursorEx(App.hInstance, "CURSOR-ARROW")
        Set m_pArrowCursor = LoadResPicture("CURSOR-ARROW", vbResCursor)
        m_lhNormalCursor = m_pArrowCursor.Handle
        Set m_pLockedCursor = LoadResPicture("CURSOR-LOCKED", vbResCursor)
        m_lhLockedCursor = m_pLockedCursor.Handle
        Set m_pNSSizeCursor = LoadResPicture("CURSOR-SIZENS", vbResCursor)
        m_lhNSSizeCursor = m_pNSSizeCursor.Handle
        Set m_pWESizeCursor = LoadResPicture("CURSOR-SIZEWE", vbResCursor)
        m_lhWESizeCursor = m_pWESizeCursor.Handle
        Set m_pDragCursor = LoadResPicture("CURSOR-DRAG", vbResCursor)
        m_lhDragCursor = m_pDragCursor.Handle
    Else
        m_lhNormalCursor = LoadCursor(0&, OCR_NORMAL)
        m_lhLockedCursor = LoadCursor(0&, OCR_NO)
        m_lhNSSizeCursor = LoadCursor(0&, OCR_SIZENS)
        m_lhWESizeCursor = LoadCursor(0&, OCR_SIZEWE)
    End If

On Error GoTo 0
Exit Sub

Handler:
    m_bCustomCursors = False

End Sub

Private Sub ColumnToolTip(ByVal lColumn As Long)

    If Not (lColumn = -1) Then
        If Not (LenB(m_sToolTipHint(lColumn)) = 0) Then
            With m_cColumnToolTip
                .CtrlHwnd = m_lHdrHwnd
                .ImlHwnd = m_lImlHdHndl
                .XPColors = m_bTipXPColors
                .BackColor = m_lTipColor
                .ColorOffset = m_lTipOffsetColor
                .DelayTime = m_lTipDelayTime
                .Gradient = m_bTipGradient
                .Icon = ColumnIcon(lColumn)
                .Multiline = m_bTipMultiline
                .Text = m_sToolTipHint(lColumn)
                .Title = ColumnText(lColumn)
                .Transparency = m_lTipTransparency
                .VisibleTime = m_lTipVisibleTime
                .ToolTipPosition = m_lTipPosition
                .Start
                .StartTimer
            End With
        End If
    End If

End Sub

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

Dim lChar   As Long
Dim lHdc    As Long
Dim uLF     As LOGFONT

On Error GoTo Handler

    If (oFont Is Nothing) Then
        Set oFont = New StdFont
        With oFont
            .Charset = 3
            .Name = "MS Sans Serif"
            .Weight = 400
            .Size = 9
        End With
    End If
    
    lHdc = CreateDc("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    With uLF
         For lChar = 1 To Len(oFont.Name)
             .lfFaceName(lChar - 1) = CByte(Asc(Mid$(oFont.Name, lChar, 1)))
         Next lChar
         .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
         If m_bIsXp Then
            .lfQuality = LF_CLEARTYPE_QUALITY
         Else
            .lfQuality = LF_ANTIALIASED_QUALITY
         End If
         If bVertical Then
            .lfEscapement = 900
        End If
    End With
    DeleteDC lHdc
    
    If m_bUseUnicode Then
        CreateFont = CreateFontIndirectW(uLF)
    Else
        CreateFont = CreateFontIndirectA(uLF)
    End If

Handler:
    On Error GoTo 0

End Function

Private Sub DestroyCursors()

    If Not m_lhNSSizeCursor = 0 Then
        DestroyCursor m_lhNSSizeCursor
        m_lhNSSizeCursor = 0
    End If
    If Not m_lhNormalCursor = 0 Then
        DestroyCursor m_lhNormalCursor
        m_lhNormalCursor = 0
    End If
    If Not m_lhWESizeCursor = 0 Then
        DestroyCursor m_lhWESizeCursor
        m_lhWESizeCursor = 0
    End If
    If Not m_lhLockedCursor = 0 Then
        DestroyCursor m_lhLockedCursor
        m_lhLockedCursor = 0
    End If
    If Not m_lhDragCursor = 0 Then
        DestroyCursor m_lhDragCursor
        m_lhDragCursor = 0
    End If
    
    If Not m_pArrowCursor Is Nothing Then Set m_pArrowCursor = Nothing
    If Not m_pLockedCursor Is Nothing Then Set m_pLockedCursor = Nothing
    If Not m_pNSSizeCursor Is Nothing Then Set m_pNSSizeCursor = Nothing
    If Not m_pWESizeCursor Is Nothing Then Set m_pWESizeCursor = Nothing
    If Not m_pDragCursor Is Nothing Then Set m_pDragCursor = Nothing

End Sub

Private Sub DestroyFont()

    If Not (m_lhFnt = 0) Then
        DeleteObject m_lhFnt
        m_lhFnt = 0
        If Not (m_oFont Is Nothing) Then
            Set m_oFont = Nothing
        End If
    End If

End Sub

Private Sub DestroyVericalFont()

    If Not (m_lvFntDc = 0) Then
        DeleteObject m_lvFntDc
        m_lvFntDc = 0
        If Not (m_oVtFont Is Nothing) Then
            Set m_oVtFont = Nothing
        End If
    End If

End Sub

Private Function DividerHitTest() As Long

Dim lColumn     As Long
Dim lXPos       As Long
Dim tPnt        As POINTAPI
Dim tRect       As RECT

    GetCursorPos tPnt
    ScreenToClient m_lHdrHwnd, tPnt
    With tPnt
        lColumn = ColumnHitTest(.x, .y, True)
        SendMessageA m_lHdrHwnd, HDM_GETITEMRECT, lColumn, tRect
        If (.x > (tRect.Left + 8)) Then
            lXPos = tRect.Right
        Else
            lXPos = tRect.Left
            lColumn = lColumn - 1
        End If
    End With
    
    With tRect
        .Left = lXPos - 8
        .Right = lXPos + 8
        If m_bHeaderSizeable Then
            .bottom = .bottom - 5
        End If
    End With
    
    With tPnt
        If Not (PtInRect(tRect, .x, .y) = 0) Then
            DividerHitTest = lColumn
        Else
            DividerHitTest = -1
        End If
    End With
    
    If (lColumn > (ColumnCount - 1)) Then
        DividerHitTest = -1
    End If

End Function

Private Function DrawColumnIcon(ByVal lColumn As Long, _
                                ByVal lHdc As Long, _
                                ByRef tRect As RECT) As Boolean
'/* draw header icon

Dim lIndex  As Long
Dim lRgn    As Long

On Error GoTo Handler

    If (lColumn = -1) Then Exit Function
    If Not m_bHeaderFlat Then
        If (lColumn = m_lColumnSorted) Then
            DrawSortArrow lHdc, tRect
        End If
    End If

    If m_bColumnFilters Then
        If m_bColumnFiltered(lColumn) Then
            DrawFilterButton lHdc, lColumn, tRect
        End If
    End If
    
    If Not (m_lImlHdHndl = 0) Then
        lIndex = ColumnIcon(lColumn)
        If (lIndex > -1) Then
            With tRect
                lRgn = CreateRectRgn(.Left, .Top, .Right, .bottom)
                SelectClipRgn lHdc, lRgn
                ImageList_Draw m_lImlHdHndl, lIndex, lHdc, (.Left + 4), (.Top + ((.bottom - .Top - m_lImageWidth) \ 2)), ILD_TRANSPARENT
                SelectClipRgn lHdc, 0&
                DeleteObject lRgn
            End With
            DrawColumnIcon = True
        End If
    End If

Handler:
    On Error GoTo 0

End Function

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

'/* draw column caption
Dim bIcon       As Boolean
Dim lFontOld    As Long
Dim lAlign      As Long
Dim lWidth      As Long
Dim lOffset     As Long
Dim lFlags      As Long