coollist.ctl

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

VERSION 5.00
Begin VB.UserControl CoolList 
   ClientHeight    =   1425
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3255
   KeyPreview      =   -1  'True
   ScaleHeight     =   95
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   217
   Begin VB.VScrollBar Bar 
      Height          =   915
      Left            =   1200
      Max             =   0
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   90
      Visible         =   0   'False
      Width           =   195
   End
   Begin VB.TextBox txtEdit 
      BorderStyle     =   0  'None
      Height          =   510
      Left            =   1620
      MultiLine       =   -1  'True
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   105
      Visible         =   0   'False
      Width           =   1500
   End
   Begin VB.PictureBox iScr 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      ForeColor       =   &H80000008&
      Height          =   990
      Left            =   -15
      ScaleHeight     =   66
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   78
      TabIndex        =   2
      Top             =   45
      Width           =   1170
   End
End
Attribute VB_Name = "CoolList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'-------------------------------------------------------------------------------------------
' CoolList OCX 1.2 (Private UC version)
'
' Carles P.V.
' [e-mail]
'-------------------------------------------------------------------------------------------
' Last modified: 2003.02.11
'-------------------------------------------------------------------------------------------
Option Explicit

'* Declares for Unicode support.
Private Const VER_PLATFORM_WIN32_NT = 2

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128 '* Maintenance string for PSS usage.
End Type

Private mWindowsNT   As Boolean

Public Enum AlignmentCts
    [AlignLeft] = &H0
    [AlignCenter] = &H2
    [AlignRight] = &H1
End Enum

Public Enum AppearanceCts
    [Flat] = &H0
    [3D] = &H1
End Enum

Public Enum BorderStyleCts
    [None] = &H0
    [Fixed Single] = &H1
End Enum

Public Enum OrderTypeCts
    [Ascendent] = &H0
    [Descendent] = &H1
End Enum

Public Enum SelectModeCts
    [Single] = &H0
    [Multiple] = &H1
End Enum

Public Enum SelectModeStyleCts
    [Standard] = &H0
    [Dither] = &H1
    [Gradient_V] = &H2
    [Gradient_H] = &H3
    [Box] = &H4
    [Underline] = &H5
    [byPicture] = &H6
End Enum

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function GetVersionEx Lib "kernel32" _
        Alias "GetVersionExA" ( _
        lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" ( _
        ByVal nPenStyle As Long, _
        ByVal nWidth As Long, _
        ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetRect Lib "user32" ( _
        lpRect As RECT2, _
        ByVal x1 As Long, _
        ByVal y1 As Long, _
        ByVal x2 As Long, _
        ByVal y2 As Long) As Long
Private Declare Function RoundRect Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal x1 As Long, _
        ByVal y1 As Long, _
        ByVal x2 As Long, _
        ByVal y2 As Long, _
        ByVal X3 As Long, _
        ByVal Y3 As Long) As Long
Private Declare Function FillRect Lib "user32" ( _
        ByVal hDC As Long, _
        lpRect As RECT2, _
        ByVal hBrush As Long) As Long
Private Declare Function PatBlt Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal X As Long, _
        ByVal Y As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal dwRop As Long) As Long
Private Declare Function GradientFillRect Lib "msimg32" _
        Alias "GradientFill" ( _
        ByVal hDC As Long, _
        pVertex As TRIVERTEX, _
        ByVal dwNumVertex As Long, _
        pMesh As GRADIENT_RECT, _
        ByVal dwNumMesh As Long, _
        ByVal dwMode As Long) As Long
Private Declare Function DrawTextA Lib "user32" ( _
        ByVal hDC As Long, _
        ByVal lpStr As String, _
        ByVal nCount As Long, _
        lpRect As RECT2, _
        ByVal wFormat As Long) As Long
Private Declare Function DrawTextW Lib "user32" ( _
        ByVal hDC As Long, _
        ByVal lpStr As Long, _
        ByVal nCount As Long, _
        lpRect As RECT2, _
        ByVal wFormat As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect As RECT2) As Long
Private Declare Function InflateRect Lib "user32" ( _
        lpRect As RECT2, _
        ByVal dx As Long, _
        ByVal dy As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal X As Long, _
        ByVal Y As Long, _
        lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal X As Long, _
        ByVal Y As Long) As Long
Private Declare Function FrameRect Lib "user32" ( _
        ByVal hDC As Long, _
        lpRect As RECT2, _
        ByVal hBrush As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Type TRIVERTEX
    X     As Long
    Y     As Long
    R     As Integer
    G     As Integer
    B     As Integer
    Alpha As Integer
End Type

Private Type RGB
    R As Integer
    G As Integer
    B As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft  As Long
    LowerRight As Long
End Type

Private Type RECT2
    x1 As Long
    y1 As Long
    x2 As Long
    y2 As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Const PS_SOLID As Long = 0

Private Const GRADIENT_FILL_RECT_H As Long = &H0
Private Const GRADIENT_FILL_RECT_V As Long = &H1

Private Const DT_LEFT       As Long = &H0
Private Const DT_VCENTER    As Long = &H4
Private Const DT_WORDBREAK  As Long = &H10
Private Const DT_SINGLELINE As Long = &H20

Private Const defSelectBorderColor = &HC56A31
Private Const defSelectListBorderColor = &H6B2408
Private Const defShadowColorText = &H80000015

'-------------------------------------------------------------------------------------------
' UserControl constants / types / variables / events
'-------------------------------------------------------------------------------------------

Private Type tItem
    Text            As String
    Icon            As Integer
    IconSelected    As Integer
    Color           As Long
    Enabled         As Boolean
    SeparatorLine   As Boolean
    TextShadow      As Boolean
    ToolTipTextItem As String
    MouseIcon       As StdPicture
End Type

Private m_List()          As tItem    ' List array of items (Text, icons)
Private m_Selected()      As Boolean  ' List array of items (Selected/Unselected)
Private m_nItems          As Integer  ' Number of Items

Private m_LastBar         As Integer  ' Last scroll bar value
Private m_LastItem        As Integer  ' Last Selected item
Private m_LastY           As Single   ' Last Y value [pixels] (prevents item repaint)
Private m_AnchorItemState As Boolean  ' Anchor item value (multiple selection).
'  Case extended selection: all selected items
'  will be set to Anchor selection state.

Private m_EnsureVisible   As Boolean  ' Ensure visible last m_Selected item (ListIndex)

Private m_ItemRct()       As RECT2    ' Item rectangle
Private m_TextRct()       As RECT2    ' Item text rectangle
Private m_IconPt()        As POINTAPI ' Item icon position

Private m_tmpItemHeight   As Integer  ' Item height [pixels]
Private m_VisibleRows     As Integer  ' Visible rows in control area
Private m_Scrolling       As Boolean  ' Scrolling by mouse
Private m_ScrollingY      As Long     ' Y Scrolling coordinate flag (scroll speed = f(Y))
Private m_HasFocus        As Boolean  ' Control has focus
Private m_Resizing        As Boolean  ' Prevent repaints when Resizing

Private m_pImgList        As Object   ' Will point to ImageList control
Private m_ILScale         As Integer  ' ImageList parent scale mode

Private m_Appearance            As AppearanceCts
Private m_SelectBorderColor     As OLE_COLOR
Private m_SelectListBorderColor As OLE_COLOR
Private m_ListGradient          As Boolean
Private m_ShadowColorText       As OLE_COLOR

Private m_ColorBack       As Long     ' Back color [Normal]
Private m_ColorBackSel    As Long     ' Back color [Selected]
Private m_ColorFont       As Long     ' Font color [Normal]
Private m_ColorFontSel    As Long     ' Font color [Selected]
Private m_ColorGradient1  As RGB      ' Gradient color from [Selected]
Private m_ColorGradient2  As RGB      ' Gradient color to [Selected]
Private m_ColorBox        As Long     ' Box border color

Private WithEvents m_Font As StdFont  ' Font object
Attribute m_Font.VB_VarHelpID = -1

Private m_Alignment        As AlignmentCts
Private m_Apeareance       As AppearanceCts
Private m_BackNormal       As OLE_COLOR
Private m_BackSelected     As OLE_COLOR
Private m_BackSelectedG1   As OLE_COLOR
Private m_BackSelectedG2   As OLE_COLOR
Private m_BoxBorder        As OLE_COLOR
Private m_BoxOffset        As Integer
Private m_BoxRadius        As Integer
Private m_Focus            As Boolean
Private m_FontNormal       As OLE_COLOR
Private m_FontSelected     As OLE_COLOR
Private m_HoverSelection   As Boolean
Private m_ItemHeight       As Integer
Private m_ItemHeightAuto   As Boolean
Private m_ItemOffset       As Integer
Private m_ItemTextLeft     As Integer
Private m_ListIndex        As Integer
Private m_OrderType        As OrderTypeCts
Private m_ScrollBarWidth   As Integer
Private m_SelectionPicture As Picture
Private m_SelectMode       As SelectModeCts
Private m_SelectModeStyle  As SelectModeStyleCts
Private m_TopIndex         As Integer
Private m_WordWrap         As Boolean

Private Const m_def_Appearance = 1
Private Const m_def_Alignment = DT_LEFT
Private Const m_def_BackNormal = vbWindowBackground
Private Const m_def_BackSelected = vbHighlight
Private Const m_def_BackSelectedG1 = vbHighlight
Private Const m_def_BackSelectedG2 = vbWindowBackground
Private Const m_def_BorderStyle = 1
Private Const m_def_BoxBorder = vbHighlightText
Private Const m_def_BoxOffset = 1
Private Const m_def_BoxRadius = 0
Private Const m_def_Focus = -1
Private Const m_def_FontNormal = vbWindowText
Private Const m_def_FontSelected = vbHighlightText
Private Const m_def_HoverSelection = 0
Private Const m_def_ItemHeightAuto = -1
Private Const m_def_ItemOffset = 0
Private Const m_def_ItemTextLeft = 2
Private Const m_def_OrderType = 0
Private Const m_def_ScrollBarWidth = 13
Private Const m_def_SelectMode = 0
Private Const m_def_SelectModeStyle = 0
Private Const m_def_WordWrap = -1

Public Event Click()
Public Event DblClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event ListIndexChange()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event Scroll()
Public Event TopIndexChange()

' Hack for XP Crash with VB6 controls:
Private m_hMod As Long

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long

'-------------------------------------------------------------------------------------------
' Init/Read/Write properties
'-------------------------------------------------------------------------------------------


Public Sub AddItem(ByVal Text As Variant, Optional ByVal Icon As Integer, Optional ByVal _
                   IconSelected As Integer, Optional ByVal Color As Long, Optional ByVal Enabled _
                   As Boolean = True, Optional ByVal ToolTipTextItem As String = "", Optional _
                   ByVal MouseIcon As StdPicture = Nothing, Optional ByVal SeparatorLine As _
                   Boolean = False, Optional ByVal TextShadow As Boolean = False)

    '-- AddItem
    '-- 0 , ... , n-1 [n = ListCount]

    m_List(m_nItems).Text = CStr(Text)
    m_List(m_nItems).Icon = Icon
    m_List(m_nItems).IconSelected = IconSelected
    m_List(m_nItems).Color = Color
    m_List(m_nItems).Enabled = Enabled
    m_List(m_nItems).SeparatorLine = SeparatorLine
    Set m_List(m_nItems).MouseIcon = MouseIcon
    m_List(m_nItems).TextShadow = TextShadow
    m_List(m_nItems).ToolTipTextItem = ToolTipTextItem
    m_nItems = m_nItems + 1
    ReDim Preserve m_List(m_nItems)
    ReDim Preserve m_Selected(m_nItems)
    Call ReadjustBar
    If (m_nItems < m_VisibleRows + 1) Then Call DrawItem((m_nItems - 1))

End Sub

Public Property Let Alignment(ByVal New_Alignment As AlignmentCts)

    m_Alignment = New_Alignment
    Call iScr_Paint

End Property

Public Property Get Alignment() As AlignmentCts

    '-------------------------------------------------------------------------------------------
    ' Properties
    '-------------------------------------------------------------------------------------------
    '-- Alignment

    Alignment = m_Alignment

End Property

Private Function APIRectangle(ByVal hDC As Long, _
                              ByVal X As Long, _
                              ByVal Y As Long, _
                              ByVal W As Long, _
                              ByVal H As Long, _
                              Optional ByVal lColor As OLE_COLOR = -1) As Long

  Dim hPen As Long
  Dim hPenOld As Long
  Dim PT   As POINTAPI

    hPen = CreatePen(0, 1, lColor)
    hPenOld = SelectObject(hDC, hPen)
    Call MoveToEx(hDC, X, Y, PT)
    Call LineTo(hDC, X + W, Y)
    Call LineTo(hDC, X + W, Y + H)
    Call LineTo(hDC, X, Y + H)
    Call LineTo(hDC, X, Y)
    Call SelectObject(hDC, hPenOld)
    Call DeleteObject(hPen)

End Function

Public Property Let Appearance(ByVal New_Appearance As AppearanceCts)

    m_Appearance = New_Appearance

End Property

Public Property Get Appearance() As AppearanceCts

    '-- Appearance

    Appearance = m_Appearance

End Property

Public Property Let BackNormal(ByVal New_BackNormal As OLE_COLOR)

    m_BackNormal = New_BackNormal
    m_ColorBack = GetLngColor(m_BackNormal)
    iScr.BackColor = m_ColorBack
    Call iScr_Paint

End Property