clsskinscrollbars.cls

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

                If (lDiff > 20) Then
                    DrawGlyph True, lHdc, lXOffset
                End If
            Else
                m_cRender.Stretch lHdc, 0, (m_tVScrBar.xyThumbBottom - lDiff), m_lVXScroll, lDiff, .hdc, ((.Width / 2) * lXOffset), 0, (.Width / 2), .Height, SRCCOPY
            End If
        End With
        '/* copy to dest
        m_cRender.Blit lSclHdc, 0, 0, .Right, .bottom, lHdc, 0, 0, SRCCOPY
    End With
    
    '/* cleanup
    SelectObject lHdc, lBmpOld
    DeleteObject lBmp
    DeleteDC lHdc
    ReleaseDC m_lVScrollHnd, lSclHdc

Handler:
    On Error GoTo 0
    
End Sub

Private Sub DrawGlyph(ByVal bVertical As Boolean, _
                      ByVal lHdc As Long, _
                      ByVal lOffset As Long)

Dim lBaseClr    As Long
Dim lCenter     As Long
Dim lhPen       As Long
Dim lhPenOld    As Long
Dim tPnt        As POINTAPI

    If bVertical Then
        lBaseClr = GetPixel(m_cVThumbDc.hdc, 3&, 3&)
        If (lOffset > 0) Then
            lBaseClr = m_cRender.BlendColor(lBaseClr, &HFDFDFD)
        Else
            lBaseClr = m_cRender.BlendColor(lBaseClr, &H0)
        End If
        lhPen = CreatePen(0&, 1&, lBaseClr)
        lhPenOld = SelectObject(lHdc, lhPen)
        '/* draw outline
        With m_tVScrBar
            lCenter = .xyThumbTop + ((.xyThumbBottom - .xyThumbTop) / 2)
            MoveToEx lHdc, 6&, (lCenter - 3), tPnt
            LineTo lHdc, (m_lVXScroll - 6), (lCenter - 3)
            MoveToEx lHdc, 4&, lCenter, tPnt
            LineTo lHdc, (m_lVXScroll - 4), lCenter
            MoveToEx lHdc, 6&, (lCenter + 3), tPnt
            LineTo lHdc, (m_lVXScroll - 6), (lCenter + 3)
            SelectObject lHdc, lhPenOld
            DeleteObject lhPen
        End With
    Else
        lBaseClr = GetPixel(m_cHThumbDc.hdc, 3&, 3&)
        If (lOffset > 0) Then
            lBaseClr = m_cRender.BlendColor(lBaseClr, &HFDFDFD)
        Else
            lBaseClr = m_cRender.BlendColor(lBaseClr, &H0)
        End If
        lhPen = CreatePen(0&, 1&, lBaseClr)
        lhPenOld = SelectObject(lHdc, lhPen)
        '/* draw outline
        With m_tHScrBar
            lCenter = .xyThumbTop + ((.xyThumbBottom - .xyThumbTop) / 2)
            MoveToEx lHdc, (lCenter - 3), 6&, tPnt
            LineTo lHdc, (lCenter - 3), (m_lVXScroll - 6)
            
            MoveToEx lHdc, lCenter, 4&, tPnt
            LineTo lHdc, lCenter, (m_lVXScroll - 4)
            
            MoveToEx lHdc, (lCenter + 3), 6&, tPnt
            LineTo lHdc, (lCenter + 3), (m_lVXScroll - 6)
            
            SelectObject lHdc, lhPenOld
            DeleteObject lhPen
        End With
    End If
    
End Sub

Public Sub Resize()
    ResetSCPos
End Sub

Friend Function ScrollVertical(ByVal bDown As Boolean)

    If bDown Then
        SendMessageLong m_lCtrlHnd, WM_VSCROLL, SB_LINEDOWN, 0&
    Else
        SendMessageLong m_lCtrlHnd, WM_VSCROLL, SB_LINEUP, 0&
    End If
    
End Function

Friend Function ScrollHorizontal(ByVal bRight As Boolean)

    If bRight Then
        SendMessageLong m_lCtrlHnd, WM_HSCROLL, SB_LINERIGHT, 0&
    Else
        SendMessageLong m_lCtrlHnd, WM_HSCROLL, SB_LINELEFT, 0&
    End If
    
End Function

Friend Function HasHorizontal() As Boolean

Dim lStyle   As Long

    lStyle = GetWindowLong(m_lCtrlHnd, GWL_STYLE)
    HasHorizontal = (lStyle And WS_HSCROLL) <> 0

End Function

Friend Function HasVertical() As Boolean

Dim lStyle  As Long

    lStyle = GetWindowLong(m_lCtrlHnd, GWL_STYLE)
    HasVertical = (lStyle And WS_VSCROLL) <> 0

End Function

Private Function HasSizer() As Boolean

Dim bHorizontal As Boolean
Dim bVertical   As Boolean
Dim lStyle      As Long

    lStyle = GetWindowLong(m_lCtrlHnd, GWL_STYLE)
    bHorizontal = (lStyle And WS_HSCROLL) <> 0
    bVertical = (lStyle And WS_VSCROLL) <> 0
    HasSizer = (bHorizontal And bVertical)
    
End Function

Private Sub BarVisible(ByVal lHwnd As Long)
'/* bar status

Dim lStyle   As Long

    lStyle = GetWindowLong(lHwnd, GWL_STYLE)
    m_bHasHorizontal = (lStyle And WS_HSCROLL) <> 0
    m_bHasVertical = (lStyle And WS_VSCROLL) <> 0
    m_bHasSizer = (m_bHasHorizontal And m_bHasVertical)
    ScrollbarStatus

End Sub

Friend Function Refresh()

    m_bSelect = False
    SendMessageLong m_lCtrlHnd, WM_PAINT, 0&, 0&
    
End Function

Private Sub ScrollbarStatus()

    If (IsWindowVisible(m_lCtrlHnd) = 0) Then
        MaskShow m_lHScrollHnd, False
        MaskShow m_lVScrollHnd, False
        MaskShow m_lSizerHnd, False
        Exit Sub
    End If
    
    If HasHorizontal Then
        MaskShow m_lHScrollHnd, True
    Else
        MaskShow m_lHScrollHnd, False
    End If
    
    If HasVertical Then
        MaskShow m_lVScrollHnd, True
    Else
        MaskShow m_lVScrollHnd, False
    End If
    
    If HasSizer Then
        MaskShow m_lSizerHnd, True
    Else
        MaskShow m_lSizerHnd, False
    End If

End Sub

Public Property Get Visible() As Boolean
    Visible = m_bVisible
End Property

Public Property Let Visible(PropVal As Boolean)

    If PropVal Then
        If Not m_bVisible Then
            ScrollbarStatus
            m_bScrollBarActive = True
            SendMessageLong m_lCtrlHnd, WM_PAINT, 0&, 0&
        End If
    Else
        MaskShow m_lHScrollHnd, False
        MaskShow m_lVScrollHnd, False
        MaskShow m_lSizerHnd, False
        m_bScrollBarActive = False
    End If
    m_bVisible = PropVal

End Property

Private Sub SkinAttach()

    If m_GXScrollbar Is Nothing Then
        Set m_GXScrollbar = New GXMSubclass
        With m_GXScrollbar
            .Subclass m_lCtrlHnd, Me
            .AddMessage m_lCtrlHnd, WM_ERASEBKGND, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_PAINT, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_STYLECHANGED, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_WINDOWPOSCHANGED, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_VSCROLL, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_HSCROLL, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_SIZE, MSG_BEFORE
            .AddMessage m_lCtrlHnd, WM_NCLBUTTONDOWN, MSG_BEFORE
        End With
    End If
    
End Sub

Private Sub SkinDetach()

    If Not m_GXScrollbar Is Nothing Then
        With m_GXScrollbar
            .DeleteMessage m_lCtrlHnd, WM_ERASEBKGND, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_PAINT, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_STYLECHANGED, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_WINDOWPOSCHANGED, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_VSCROLL, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_HSCROLL, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_SIZE, MSG_BEFORE
            .DeleteMessage m_lCtrlHnd, WM_NCLBUTTONDOWN, MSG_BEFORE
            .UnSubclass m_lCtrlHnd
        End With
        Set m_GXScrollbar = Nothing
    End If
        
End Sub

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 wStyle          As Long
Static lStyle       As Long

On Error GoTo Handler

    If (IsWindowVisible(m_lCtrlHnd) = 0) Then
        BarVisible m_lCtrlHnd
        Exit Sub
    Else
        BarVisible m_lCtrlHnd
    End If
    
    If Not m_bScrollBarActive Then
        Exit Sub
    End If

    Select Case uMsg
    '/* client paint
    Case WM_PAINT
        If Not m_bSelect Then
            If HasHorizontal Then
                StoreHorizontal lHwnd
                HorzBarPaint
            End If
            If HasVertical Then
                StoreVertical lHwnd
                VertBarPaint
            End If
        Else
            m_bSelect = False
        End If
        lReturn = m_GXScrollbar.CallOldWndProc(lHwnd, uMsg, wParam, lParam)
        bHandled = True
    
    '/* horizontal scroll
    Case WM_HSCROLL
        lReturn = m_GXScrollbar.CallOldWndProc(lHwnd, uMsg, wParam, lParam)
        If Not (wParam = SBN_ENDSCROLL) Then
            m_eScrollDirection = efsHorizontal
        Else
            m_eScrollDirection = efsNone
        End If
        StoreHorizontal lHwnd
        m_bSelect = True
        HorzBarPaint
        bHandled = True
    
    '/* vertical Scroll
    Case WM_VSCROLL
        lReturn = m_GXScrollbar.CallOldWndProc(lHwnd, uMsg, wParam, lParam)
        If Not (wParam = SBN_ENDSCROLL) Then
            m_eScrollDirection = efsVertical
        Else
            m_eScrollDirection = efsNone
        End If
        StoreVertical lHwnd
        m_bSelect = True
        VertBarPaint
        bHandled = True

    Case WM_WINDOWPOSCHANGED, WM_STYLECHANGED
        ScrollbarStatus
    
    Case WM_SIZE
        wStyle = GetWindowLong(lHwnd, GWL_STYLE)
        If Not wStyle = lStyle Then
            ResetSCPos
            lStyle = wStyle
        End If

    Case WM_ERASEBKGND
        If HasHorizontal Then
            StoreHorizontal lHwnd
            HorzBarPaint
        End If
        If HasVertical Then
            StoreVertical lHwnd
            VertBarPaint
        End If
        lReturn = m_GXScrollbar.CallOldWndProc(lHwnd, uMsg, wParam, lParam)
        bHandled = True
    End Select
    
Handler:

End Sub

Private Sub CleanUp()

    If Not (m_lCtrlHnd = 0) Then
        If m_bSkinScrollBar Then
            CleanupSkin
        End If
        m_lCtrlHnd = 0
        m_bInitialised = False
    End If
    
End Sub

Private Sub CleanupSkin()

    If Not (m_lCtrlHnd = 0) Then
        SkinDetach
        DestroyScrollbar SB_BOTH
        If Not m_cVTrackDc Is Nothing Then Set m_cVTrackDc = Nothing
        If Not m_cVThumbDc Is Nothing Then Set m_cVThumbDc = Nothing
        If Not m_cBtDwnDc Is Nothing Then Set m_cBtDwnDc = Nothing
        If Not m_cBtUpDc Is Nothing Then Set m_cBtUpDc = Nothing
        If Not m_cHTrackDc Is Nothing Then Set m_cHTrackDc = Nothing
        If Not m_cHThumbDc Is Nothing Then Set m_cHThumbDc = Nothing
        If Not m_cHBtLftDc Is Nothing Then Set m_cHBtLftDc = Nothing
        If Not m_cHBtRgtDc Is Nothing Then Set m_cHBtRgtDc = Nothing
        If Not m_cSzrDc Is Nothing Then Set m_cSzrDc = Nothing
        If Not m_cRender Is Nothing Then Set m_cRender = Nothing
        If Not m_pVTrack Is Nothing Then Set m_pVTrack = Nothing
        If Not m_pVThumb Is Nothing Then Set m_pVThumb = Nothing
        If Not m_pVBtDwn Is Nothing Then Set m_pVBtDwn = Nothing
        If Not m_pVBtUp Is Nothing Then Set m_pVBtUp = Nothing
        If Not m_pHTrack Is Nothing Then Set m_pHTrack = Nothing
        If Not m_pHThumb Is Nothing Then Set m_pHThumb = Nothing
        If Not m_pHBtLft Is Nothing Then Set m_pHBtLft = Nothing
        If Not m_pHBtRgt Is Nothing Then Set m_pHBtRgt = Nothing
        If Not m_pSizer Is Nothing Then Set m_pSizer = Nothing
        m_lHScrollHnd = 0
        m_lVScrollHnd = 0
        m_lSizerHnd = 0
    End If

End Sub

Private Sub Class_Terminate()
    CleanUp
End Sub