ilist.ctl

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

End Sub


'Api (heh)
Sub PrintAt(x As Long, y As Long, Text As String)
    P.CurrentX = x
    P.CurrentY = y
    P.Print Text
End Sub
Sub MoveTo(x, y)
    P.CurrentX = x
    P.CurrentY = y
End Sub

Sub LineTo(x, y, Optional Color As Long = 0)
    P.Line -(x, y), Color
End Sub
Sub TextOut(Text As String)
    P.Print Text
End Sub
Sub Rectangle(x As Long, y As Long, Width As Long, Height As Long, _
              Optional Color As Long = vbHighlight)
    P.Line (x, y)-Step(Width, Height), Color, BF
End Sub
Function RoundEx(x)
    If x > CLng(x) Then
        RoundEx = CLng(x) + 1
    Else
        RoundEx = CLng(x)
    End If
End Function




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

Public Property Let IconPosX(ByVal New_IconPosX As Long)
    m_IconPosX = New_IconPosX
    PropertyChanged "IconPosX"
End Property

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

Public Property Let IconPosY(ByVal New_IconPosY As Long)
    m_IconPosY = New_IconPosY
    PropertyChanged "IconPosY"
End Property

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

Public Property Let CaptionPosX(ByVal New_CaptionPosX As Long)
    m_CaptionPosX = New_CaptionPosX
    PropertyChanged "CaptionPosX"
End Property

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

Public Property Let CaptionPosY(ByVal New_CaptionPosY As Long)
    m_CaptionPosY = New_CaptionPosY
    PropertyChanged "CaptionPosY"
End Property

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

Public Property Let TextPosX(ByVal New_TextPosX As Long)
    m_TextPosX = New_TextPosX
    PropertyChanged "TextPosX"
End Property

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

Public Property Let TextPosY(ByVal New_TextPosY As Long)
    m_TextPosY = New_TextPosY
    PropertyChanged "TextPosY"
End Property

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

Public Property Let Selected(ByVal New_Selected As Long)

Dim y As Long
Dim T As Long
If New_Selected > Count Then New_Selected = Count

If New_Selected <> m_Selected Then
        'Clear
        T = m_Selected
        m_Selected = New_Selected
        
        y = (T - Scroll.Value - 1) * m_ItemHeight
        Rectangle 0, y, P.ScaleWidth, m_ItemHeight, vbWhite
        DrawItem T
        DrawItem m_Selected
        
        RaiseEvent OnSelect
End If

    PropertyChanged "Selected"
End Property
Sub SetPos(CaptionX As Long, CaptionY As Long, _
           TextX As Long, TextY As Long, _
           IconX As Long, IconY As Long)
    m_CaptionPosX = CaptionX
    m_CaptionPosY = CaptionY
    m_TextPosX = TextX
    m_TextPosY = TextY
    m_IconPosX = IconX
    m_IconPosY = IconY
    Redraw
End Sub

Function IsVisible(Index As Long) As Boolean
    Dim Ips As Long
    Ips = (P.ScaleHeight \ m_ItemHeight)
    If Index > Scroll.Value And Index < Scroll.Value + Ips + 1 Then
        IsVisible = True
    End If
End Function

Sub ScrollTo(Index As Long)
    Dim Ips As Long
    Ips = (P.ScaleHeight \ m_ItemHeight)
    If Scroll.Visible = False Then Exit Sub
    If Count > Index + Ips Then
        Scroll.Value = Index - 1
    Else
        Scroll.Value = Count - Ips
    End If
End Sub


Private Sub SetScroll()
    
    Scroll.Max = Count - Int(P.ScaleHeight / m_ItemHeight)
    If Scroll.Max <= 0 Then
        Scroll.Max = 0
        Scroll.Visible = False
    Else
        Scroll.Visible = True
    End If
End Sub

Private Sub P_Click()
    RaiseEvent Click
  
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=P,P,-1,hWnd
Public Property Get hWnd() As Long
Attribute hWnd.VB_Description = "Returns a handle (from Microsoft Windows) to an object's window."
    hWnd = P.hWnd
End Property

Private Sub P_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseDown(Button, Shift, x, y)
    Selected = RoundEx(y / m_ItemHeight) + Scroll.Value
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=P,P,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Attribute MouseIcon.VB_Description = "Sets a custom mouse icon."
    Set MouseIcon = P.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
    Set P.MouseIcon = New_MouseIcon
    PropertyChanged "MouseIcon"
End Property

Private Sub P_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    RaiseEvent MouseMove(Button, Shift, x, y)
    If Button = 1 Then
        If y > 0 And y < P.ScaleHeight Then
            Timer1.Enabled = False
            Selected = RoundEx(y / m_ItemHeight) + Scroll.Value
        Else
        
            If y < 0 Then
                m_Scroll = 1
            ElseIf y > P.ScaleHeight Then
                m_Scroll = 2
            End If
            Timer1.Enabled = True
        End If
    End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=P,P,-1,MousePointer
Public Property Get MousePointer() As MousePointerConstants
Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
    MousePointer = P.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
    P.MousePointer() = New_MousePointer
    PropertyChanged "MousePointer"
End Property

Private Sub P_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Timer1.Enabled = False
    RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

Private Sub P_DblClick()
    RaiseEvent DblClick
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=P,P,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = P.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set P.Font = New_Font
    PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=P,P,-1,hDC
Public Property Get hdc() As Long
Attribute hdc.VB_Description = "Returns a handle (from Microsoft Windows) to the object's device context."
    hdc = P.hdc
End Property

Private Sub P_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
    On Error Resume Next
    If Working = True Then Exit Sub
    Select Case KeyCode
        Case Is = vbKeyUp
            If Selected > 1 Then Selected = Selected - 1
            If IsVisible(Selected) = False Then
                If Scroll.Value > 0 Then
                    'DoEvents
                    Working = True
                    Scroll.Value = Scroll.Value - 1
                End If
            End If
        Case Is = vbKeyDown
            If Selected < Count Then Selected = Selected + 1
            If IsVisible(Selected) = False Then
                If Scroll.Value < Scroll.Max Then
                    'DoEvents
                    Working = True
                    Scroll.Value = Scroll.Value + 1
                End If
            End If
    End Select
End Sub

Private Sub P_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub P_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Public Sub SetCaption(Index, Caption As String)
    CItems(Index).Caption = Caption
    DrawItem Index
End Sub


Public Sub SetText(Index, Text As String)
    CItems(Index).Text = Text
    DrawItem Index
End Sub