coollist.ctl

这个是属性空间 比较不错 可以和系统的相媲美

End Property

Public Property Let ItemIconSelected(ByVal Index As Integer, ByVal Data As Integer)

    If (m_nItems = 0 Or Index > m_nItems) Then Call Err.Raise(381)
    m_List(Index).IconSelected = Data
    Call DrawItem(Index)
    Call DrawFocus(m_ListIndex)

End Property

Public Property Get ItemOffset() As Integer

    '-- ItemOffset

    ItemOffset = m_ItemOffset

End Property

Public Property Let ItemOffset(ByVal New_ItemOffset As Integer)

    If (New_ItemOffset <= m_tmpItemHeight) Then
        m_ItemOffset = New_ItemOffset
    End If

    Call CalculateRects
    If (Bar.Visible = True) Then Call RigthOffsetRects(Bar.Width)
    Call iScr_Paint

End Property

Public Property Get ItemPicture(ByVal Index As Integer)

    Set ItemPicture = m_pImgList.ListImages(Index).ExtractIcon

End Property

Public Property Get ItemSelected(ByVal Index As Integer) As Boolean

    '-- ItemSelected

    If (m_nItems = 0 Or Index > m_nItems) Then Call Err.Raise(381)
    ItemSelected = m_Selected(Index)

End Property

Public Property Let ItemSelected(ByVal Index As Integer, ByVal Data As Boolean)

    If (m_nItems = 0) Or (Index > m_nItems) Then Call Err.Raise(381)

    Select Case Data
    Case -1

        If (m_SelectMode = [Single]) Then
            ListIndex = Index
        Else
            m_Selected(Index) = -1
            Call DrawItem(Index)
            If (Index = m_ListIndex) Then Call DrawFocus(Index)
        End If

    Case 0

        If Not (m_SelectMode = [Single]) Then
            m_Selected(Index) = 0
            Call DrawItem(Index)
            If (Index = m_ListIndex) Then Call DrawFocus(Index)
        End If

    End Select

End Property

Public Property Get ItemText(ByVal Index As Integer) As String

    'Last revised: 02/07/02
    '-------------------------------------------------------------------------------------------
    ' Some methods passed to R/W properties:
    '
    ' GetItem i    GetIcon i    GetIconSelected i    IsSelected i
    ' to           to           to                   to
    ' ItemText(i)  ItemIcon(i)  ItemIconSelected(i)  ItemSelected(i)
    '
    ' Or use ModifyItem to change all item parameters at time
    '-- ItemText

    If (m_nItems = 0 Or Index > m_nItems) Then Call Err.Raise(381)
    ItemText = m_List(Index).Text

End Property

Public Property Let ItemText(ByVal Index As Integer, ByVal Data As String)

    If (m_nItems = 0 Or Index > m_nItems) Then Call Err.Raise(381)
    m_List(Index).Text = CStr(Data)
    Call DrawItem(Index)
    Call DrawFocus(m_ListIndex)

End Property

Public Property Let ItemTextLeft(ByVal New_ItemTextLeft As Integer)

    m_ItemTextLeft = New_ItemTextLeft
    Call CalculateRects
    If (Bar.Visible = True) Then Call RigthOffsetRects(Bar.Width)
    Call iScr_Paint

End Property

Public Property Get ItemTextLeft() As Integer

    '-- ItemTextLeft

    ItemTextLeft = m_ItemTextLeft

End Property

Public Property Get ListCount() As Integer

    '-- <ListCount>

    ListCount = m_nItems

End Property

Public Property Get ListGradient() As Boolean

    ListGradient = m_ListGradient

End Property

Public Property Let ListGradient(ByVal New_Gradient As Boolean)

    m_ListGradient = New_Gradient
    Call PropertyChanged("ListGradient")

End Property

Public Property Get ListIndex() As Integer

    '-- ListIndex

    ListIndex = m_ListIndex

End Property

Public Property Let ListIndex(ByVal New_ListIndex As Integer)

    If (New_ListIndex < -1) Or (New_ListIndex > m_nItems - 1) Then Call Err.Raise(380)
    If (txtEdit.Visible = True) Then Call txtEdit_LostFocus

    If (New_ListIndex < 0 Or m_nItems = 0) Then
        m_ListIndex = -1
        m_LastY = -1
    Else
        m_ListIndex = New_ListIndex
    End If

    '-- Unselect last / Select actual [Single selection mode]

    If (m_SelectMode = [Single]) Then
        If (m_LastItem > -1) Then m_Selected(m_LastItem) = 0
        If (m_ListIndex > -1) Then m_Selected(m_ListIndex) = -1
    End If

    '-- Draw last (delete Focus) ...
    Call Refresh
    Call DrawItem(m_LastItem)
    m_LastItem = m_ListIndex
    '-- ... and draw actual (draw Focus)
    Call DrawItem(m_ListIndex)
    Call DrawFocus(m_ListIndex)
    '-- Ensure visible actual Selected item

    If (m_EnsureVisible = True) Then
        If (m_ListIndex < Bar) And (m_ListIndex > -1) Then
            Bar = m_ListIndex
        ElseIf (m_ListIndex > Bar + m_VisibleRows - 1) Then
            Bar = m_ListIndex - m_VisibleRows + 1
        End If

    Else
        m_EnsureVisible = -1
    End If

    RaiseEvent ListIndexChange

End Property

Public Sub ModifyItem(ByVal Index As Integer, _
                      Optional ByVal Text As Variant = vbEmpty, _
                      Optional ByVal Icon As Integer = -1, _
                      Optional ByVal IconSelected As Integer = -1)

    '-- ModifyItem

    If (m_nItems = 0 Or Index > m_nItems) Then Call Err.Raise(381)
    If (Text <> vbEmpty) Then m_List(Index).Text = CStr(Text)
    If (Icon > -1) Then m_List(Index).Icon = Icon
    If (IconSelected > -1) Then m_List(Index).IconSelected = IconSelected
    Call DrawItem(Index)
    Call DrawFocus(m_ListIndex)

End Sub

Public Property Get MouseIcon() As Picture

    '-- MouseIcon

    Set MouseIcon = iScr.MouseIcon

End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)

    Set iScr.MouseIcon = New_MouseIcon

End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)

    iScr.MousePointer() = New_MousePointer

End Property

Public Property Get MousePointer() As MousePointerConstants

    '-- MousePointer

    MousePointer = iScr.MousePointer

End Property

Private Sub m_Font_FontChanged(ByVal PropertyName As String)

    Set iScr.Font = m_Font
    Call UserControl_Resize

End Sub

Public Sub Order()

    '-- Order

  Dim i0     As Long
  Dim i1      As Long
  Dim i2     As Long
  Dim d       As Long
  Dim xItem  As tItem
  Dim bDesc As Boolean

    If (m_nItems > 1) Then
        i0 = 0
        bDesc = (m_OrderType = [Descendent])

        If (m_SelectMode = [Single]) Then
            If (m_ListIndex > -1) Then m_Selected(m_ListIndex) = 0
        End If

        Do
            d = d * 3 + 1
        Loop Until (d > m_nItems)

        Do
            d = d \ 3

            For i1 = d + i0 To m_nItems + i0 - 1
                xItem = m_List(i1)
                i2 = i1

                Do While ((m_List(i2 - d).Text > xItem.Text) Xor bDesc)
                    m_List(i2) = m_List(i2 - d)
                    i2 = i2 - d
                    If (i2 - d < i0) Then Exit Do
                Loop

                m_List(i2) = xItem
            Next

        Loop Until (d = 1)
        ListIndex = -1
        Bar = 0
        '-- Unselect all and refresh
        ReDim m_Selected(0 To m_nItems)
        Call iScr_Paint
    End If

End Sub

Public Property Let OrderType(ByVal New_OrderType As OrderTypeCts)

    m_OrderType = New_OrderType

End Property

Public Property Get OrderType() As OrderTypeCts

    '-- OrderType

    OrderType = m_OrderType

End Property

Private Sub ReadjustBar()

    If (m_nItems > m_VisibleRows) Then
        If Not (Bar.Visible = True) Then
            '-- Show scroll bar
            Bar.Visible = -1
            Call Bar.Refresh
            Bar.LargeChange = IIf(m_VisibleRows = 0, 1, m_VisibleRows)
            '-- Update item rects. right margin
            Call RigthOffsetRects(Bar.Width)
            '-- Repaint control area
            Call iScr_Paint
        End If

    Else
        '-- Hide scroll bar
        Bar.Visible = 0
        '-- Update item rects. right margin
        Call RigthOffsetRects(0)
    End If

    '-- Update Bar max value
    Bar.Max = m_nItems - m_VisibleRows

End Sub

Public Sub Refresh()

    Call ReadjustBar
    Call DrawList

End Sub

Public Sub RemoveItem(ByVal Index As Integer)

    '-- RemoveItem

  Dim i As Long

    If (m_nItems = 0 Or Index > m_nItems - 1) Then Call Err.Raise(381)

    If (Index < m_nItems) Then

        For i = Index To m_nItems - 1
            m_List(i) = m_List(i + 1)
            m_Selected(i) = m_Selected(i + 1)
        Next

    End If
    m_nItems = m_nItems - 1
    ReDim Preserve m_List(m_nItems)
    ReDim Preserve m_Selected(m_nItems)
    Call ReadjustBar
    m_EnsureVisible = 0

    If (Index < m_ListIndex) Then
        If (m_ListIndex > -1) Then ListIndex = ListIndex - 1
    ElseIf (Index = m_ListIndex) Then
        ListIndex = -1
    End If

    If (m_nItems < m_VisibleRows) Then Call iScr.Cls
    Call iScr_Paint

End Sub

Private Sub RigthOffsetRects(ByVal Offset As Long)

  Dim i As Long

    For i = 0 To m_VisibleRows - 1
        m_ItemRct(i).x2 = ScaleWidth - Offset
        m_TextRct(i).x2 = ScaleWidth - m_ItemOffset - Offset
    Next

End Sub

Public Property Let ScrollBarWidth(ByVal New_ScrollBarWidth As Integer)

    '-- Check Min value width...

    If (New_ScrollBarWidth < 9) Then
        m_ScrollBarWidth = 9
        Bar.Width = 9
        '-- Check Max value width...
    ElseIf (New_ScrollBarWidth > ScaleWidth * 0.5) Then
        m_ScrollBarWidth = ScaleWidth * 0.5
        Bar.Width = ScaleWidth * 0.5
        '-- Set new value...
    Else
        m_ScrollBarWidth = New_ScrollBarWidth
        Bar.Width = New_ScrollBarWidth
    End If

    Bar.Visible = 0
    Call ReadjustBar
    Call UserControl_Resize

End Property

Public Property Get ScrollBarWidth() As Integer

    '-- ScrollBarWidth

    ScrollBarWidth = m_ScrollBarWidth

End Property

Private Sub ScrollDown()

    '-- ScrollDown

  Dim t As Long ' Timer counter
  Dim d As Long ' Scrolling delay

    d = 500 - 20 * (m_ScrollingY - ScaleHeight - 1)
    If (d < 40) Then d = 40
    '-- Scroll while MouseDown and mouse pos. > "Control bottom"

    Do While (m_Scrolling = True) And (m_ScrollingY > ScaleHeight - 1)

        If (GetTickCount - t > d) Then
            t = GetTickCount

            If (m_ListIndex < m_nItems - 1) Then
                If (m_SelectMode = [Multiple]) Then
                    m_Selected(m_ListIndex + 1) = m_AnchorItemState
                End If

                ListIndex = ListIndex + 1
            End If

        End If
        DoEvents
    Loop

End Sub

Private Sub ScrollUp()

    '-------------------------------------------------------------------------------------------
    ' Scroll Up/Down by mouse / multiple select
    '-------------------------------------------------------------------------------------------
    '-- ScrollUp

  Dim t As Long ' Timer counter
  Dim d As Long ' Scrolling delay

    d = 500 + 20 * m_ScrollingY
    If (d < 40) Then d = 40
    '-- Scroll while MouseDown and mouse pos. < "Control Top"

    Do While (m_Scrolling = True) And (m_ScrollingY < 0)