ilist.ctl

来自「使用VB仿QQ界面开发的ICQ程序,采用C/S结架,实现简单文字聊天.」· CTL 代码 · 共 608 行 · 第 1/2 页

VERSION 5.00
Begin VB.UserControl IList 
   ClientHeight    =   3900
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4770
   ScaleHeight     =   260
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   318
   Begin VB.PictureBox P 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BeginProperty Font 
         Name            =   "Verdana"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   3525
      Left            =   90
      ScaleHeight     =   233
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   284
      TabIndex        =   0
      Top             =   45
      Width           =   4290
      Begin VB.Timer Timer1 
         Enabled         =   0   'False
         Interval        =   3
         Left            =   1035
         Top             =   1890
      End
      Begin VB.VScrollBar Scroll 
         Height          =   3405
         Left            =   3960
         Max             =   0
         TabIndex        =   1
         TabStop         =   0   'False
         Top             =   0
         Visible         =   0   'False
         Width           =   240
      End
   End
End
Attribute VB_Name = "IList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Dim CItems As New Collection
'Default Property Values:
Const m_def_Selected = 0
Const m_def_IconPosX = 0
Const m_def_IconPosY = 0
Const m_def_CaptionPosX = 0
Const m_def_CaptionPosY = 0
Const m_def_TextPosX = 0
Const m_def_TextPosY = 0
Const m_def_ItemHeight = 20
'Property Variables:

Dim m_Selected As Long
Dim m_IconPosX As Long
Dim m_IconPosY As Long
Dim m_CaptionPosX As Long
Dim m_CaptionPosY As Long
Dim m_TextPosX As Long
Dim m_TextPosY As Long
Dim m_ImageList As ImageList
Dim m_ItemHeight As Long

Dim Working As Boolean
Dim m_Scroll As Integer
'Event Declarations:
Event DblClick() 'MappingInfo=P,P,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=P,P,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=P,P,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=P,P,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=P,P,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=P,P,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=P,P,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
Event Click() 'MappingInfo=P,P,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."

Public Event OnSelect()
'#######################################################################
'#######################################################################
Sub AddItem(Caption As String, Text As String, Optional Key As Variant, Optional Icon As Variant)
    Dim Item As New CItem
    Item.Caption = Caption
    Item.Text = Text
    If IsMissing(Icon) Then
        Item.Icon = 0
    Else
        Item.Icon = Icon
    End If
    If IsMissing(Key) Then
        CItems.Add Item
    Else
        CItems.Add Item
    End If
    SetScroll
End Sub
Sub Remove(Key As Variant)
    On Error Resume Next
    CItems.Remove Key
    Redraw
    If Err.Number <> 0 Then
        Err.Raise Err.Number, "IList", Err.Description
    End If
End Sub
Sub Clear()
    Set CItems = Nothing
End Sub
Function Item(Key) As CItem
    On Error Resume Next
    Set Item = CItems.Item(Key)
    
    If Err.Number <> 0 Then
        Err.Raise Err.Number, "IList", Err.Description
    End If
End Function
Function Count() As Long
    Count = CItems.Count
End Function
'#######################################################################
'#######################################################################

Private Sub P_Paint()
    Redraw
End Sub

Private Sub Scroll_Change()
    Redraw
End Sub

Private Sub Scroll_Scroll()
    Redraw
End Sub





Private Sub Timer1_Timer()


    Select Case m_Scroll
        Case Is = 1
            P_KeyDown vbKeyUp, 0
       Case Is = 2
            P_KeyDown vbKeyDown, 0
    End Select

End Sub

Private Sub UserControl_Paint()
    Redraw
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    Redraw
    P.Move 0, 0, ScaleWidth, ScaleHeight
    Scroll.Move P.ScaleWidth - Scroll.Width, 0, Scroll.Width, P.ScaleHeight
    SetScroll
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,20
Public Property Get ItemHeight() As Long
    ItemHeight = m_ItemHeight
End Property

Public Property Let ItemHeight(ByVal New_ItemHeight As Long)
    m_ItemHeight = New_ItemHeight
    PropertyChanged "ItemHeight"
End Property
'#######################################################################
'#######################################################################
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_ItemHeight = m_def_ItemHeight
    m_IconPosX = m_def_IconPosX
    m_IconPosY = m_def_IconPosY
    m_CaptionPosX = m_def_CaptionPosX
    m_CaptionPosY = m_def_CaptionPosY
    m_TextPosX = m_def_TextPosX
    m_TextPosY = m_def_TextPosY
    m_Selected = m_def_Selected
'    Set m_FontCaption = Ambient.Font
'    Set m_FontText = Ambient.Font
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_ItemHeight = PropBag.ReadProperty("ItemHeight", m_def_ItemHeight)
    Set m_ImageList = PropBag.ReadProperty("ImageList", Nothing)
    m_IconPosX = PropBag.ReadProperty("IconPosX", m_def_IconPosX)
    m_IconPosY = PropBag.ReadProperty("IconPosY", m_def_IconPosY)
    m_CaptionPosX = PropBag.ReadProperty("CaptionPosX", m_def_CaptionPosX)
    m_CaptionPosY = PropBag.ReadProperty("CaptionPosY", m_def_CaptionPosY)
    m_TextPosX = PropBag.ReadProperty("TextPosX", m_def_TextPosX)
    m_TextPosY = PropBag.ReadProperty("TextPosY", m_def_TextPosY)
    m_Selected = PropBag.ReadProperty("Selected", m_def_Selected)
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
    P.MousePointer = PropBag.ReadProperty("MousePointer", 0)
    Set P.Font = PropBag.ReadProperty("Font", Ambient.Font)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("ItemHeight", m_ItemHeight, m_def_ItemHeight)
    Call PropBag.WriteProperty("ImageList", m_ImageList, Nothing)
    Call PropBag.WriteProperty("IconPosX", m_IconPosX, m_def_IconPosX)
    Call PropBag.WriteProperty("IconPosY", m_IconPosY, m_def_IconPosY)
    Call PropBag.WriteProperty("CaptionPosX", m_CaptionPosX, m_def_CaptionPosX)
    Call PropBag.WriteProperty("CaptionPosY", m_CaptionPosY, m_def_CaptionPosY)
    Call PropBag.WriteProperty("TextPosX", m_TextPosX, m_def_TextPosX)
    Call PropBag.WriteProperty("TextPosY", m_TextPosY, m_def_TextPosY)
    Call PropBag.WriteProperty("Selected", m_Selected, m_def_Selected)
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
    Call PropBag.WriteProperty("MousePointer", P.MousePointer, 0)
    Call PropBag.WriteProperty("Font", P.Font, Ambient.Font)
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=9,0,0,0
Public Property Get ImageList() As ImageList
    Set ImageList = m_ImageList
End Property

Public Property Set ImageList(ByVal New_ImageList As ImageList)
    Set m_ImageList = New_ImageList
    PropertyChanged "ImageList"
End Property


Public Sub Redraw()
    
    Dim i As Long
 
    Dim y As Long
    
    On Error Resume Next
    
    If Selected = 0 Then
        If Count > 0 Then
            Selected = 1
        End If
    End If
    SetScroll

    P.Cls
    Dim Ips As Long
    Ips = RoundEx(P.ScaleHeight / m_ItemHeight)
    
    For i = Scroll.Value + 1 To Count
        DrawItem i
        If i > Scroll.Value + Ips + 1 Then Exit For
    Next
    P.Refresh
    Working = False
End Sub


Sub DrawItem(Index)

On Error Resume Next

Dim y As Long
Dim Itm As CItem

Set Itm = CItems(Index)
y = (Index - Scroll.Value - 1) * m_ItemHeight

'Set forecolor and backcolor
If Selected = Index Then
   P.ForeColor = vbHighlightText
   Rectangle 0, y, P.ScaleWidth, m_ItemHeight
Else
   P.ForeColor = vbButtonText
End If

'Print caption
P.FontBold = True
PrintAt m_CaptionPosX, y + m_CaptionPosY, Itm.Caption
'Print text
P.FontBold = False
PrintAt m_TextPosX, y + m_TextPosY, Itm.Text
'Draw picture
P.PaintPicture m_ImageList.ListImages(Itm.Icon).ExtractIcon, _
               m_IconPosX, m_IconPosY + y