模仿qq的动态列表框

   这两天做了一个模仿qq动态列表框。代码很简单，这里就不详述了。有兴趣的朋友可以自己下载看看源代码。地址：

        （csdn很烂啦。资源都上传了，可就是不能马上看到。也罢，这里就贴上关键代码，貌似没有vb.net代码？？）

 

Imports System.ComponentModel
Imports System.Drawing
Imports System.Drawing.Drawing2D

Namespace ListboxExNS

    ''' <summary>
    '''类似qq登陆列表框，支持 图标及大小变化
    ''' </summary>
    ''' <remarks></remarks>
    <DefaultEvent("ItemClick")> _
    Public Class ListBoxEx
        Inherits ScrollableControl

        Public Event ItemClick(ByVal sender As Object, ByVal e As ItemClickEventArgs)

        Public Sub OnItemClick(ByVal e As ItemClickEventArgs)
            RaiseEvent ItemClick(Me, e)
        End Sub

#Region "初始化及析构"
        Sub New()
            SetStyle(ControlStyles.UserPaint + ControlStyles.OptimizedDoubleBuffer + ControlStyles.AllPaintingInWmPaint, True)
            SetStyle(ControlStyles.Selectable, True)
            SetStyle(ControlStyles.ResizeRedraw, True)
            UpdateStyles()
            AutoScroll = True
            _items = New List(Of listitem)

        End Sub
#End Region

#Region "属性"
        Public _hotItem As Int32 = 0 '默认第一个项为索引

        ''' <summary>
        ''' 图像框
        ''' </summary>
        ''' <value></value>
        ''' <returns></returns>
        ''' <remarks></remarks>
        <Description("图像框"), DefaultValue("nothing")> _
        Property Imagelist() As ImageList
            Get
                Return _Imagelist
            End Get
            Set(ByVal value As ImageList)
                _Imagelist = value
            End Set
        End Property
        Dim _Imagelist As ImageList

        ''' <summary>
        ''' 条目集合
        ''' </summary>
        ''' <value></value>
        ''' <returns></returns>
        ''' <remarks></remarks>
        <DesignerSerializationVisibility(DesignerSerializationVisibility.Content)> _
        Property Items() As List(Of listitem)
            Get
                Return _items
            End Get
            Set(ByVal value As List(Of listitem))
                _items = value
            End Set
        End Property
        Dim _items As List(Of listitem)

        Dim _itemHeight As Int32 = 24
        Property ItemHeight() As Int32
            Get
                Return _itemHeight
            End Get
            Set(ByVal value As Int32)
                _itemHeight = value
            End Set
        End Property

        Property Zoon() As Int32
            Get
                Return _zoon * 2
            End Get
            Set(ByVal value As Int32)
                _zoon = value / 2
            End Set
        End Property
        Private _zoon As Int32 = 10

        Property StringAlign() As StringAlign
            Get
                Return _StringAlign
            End Get
            Set(ByVal value As StringAlign)
                _StringAlign = value
            End Set
        End Property
        Private _StringAlign As StringAlign = StringAlign.left
#End Region

#Region "重载"

        Protected Overrides Sub OnMouseClick(ByVal e As System.Windows.Forms.MouseEventArgs)
            MyBase.OnMouseClick(e)
            Dim index As Int32 = GetItemFromPoint(e.Location)
            If index <> -1 Then
                OnItemClick(New ItemClickEventArgs(Items(index)))
            End If
        End Sub

        Protected Overrides Sub OnScroll(ByVal se As System.Windows.Forms.ScrollEventArgs)
            MyBase.OnScroll(se)
            'Dim f As Single = se.NewValue / ItemHeight
            'Dim n As Int32 = Math.Floor(f)
            'If f - n > 0.00001 Then
            '    se.NewValue = n * ItemHeight
            'End If
            Me.Invalidate()
        End Sub
        Protected Overrides Sub OnMouseMove(ByVal e As System.Windows.Forms.MouseEventArgs)
            MyBase.OnMouseMove(e)
            Dim index As Int32 = GetItemFromPoint(e.Location)
            If index <> _hotItem Then
                If index <> -1 Then _hotItem = index
                Me.Invalidate()
            End If

        End Sub

        Private Sub testpaint(ByVal e As System.Windows.Forms.PaintEventArgs)
            Dim g As Graphics = e.Graphics
            g.SmoothingMode = SmoothingMode.HighQuality
            g.TranslateTransform(AutoScrollPosition.X, AutoScrollPosition.Y)

            Dim x, y As Int32
            Dim bkclr As Color = Color.FromArgb(198, 211, 227)
            Dim clr1 As Color = Color.FromArgb(235, 244, 245)
            Dim bkP As New Pen(bkclr)
            Dim sf As New StringFormat
            sf.Alignment = StringAlign
            sf.LineAlignment = StringAlignment.Center
            Dim t As Int32

            For i As Int32 = 0 To Items.Count - 1
                If i = _hotItem - 1 Then
                    t = Zoon
                ElseIf i = _hotItem Then
                    t = 2 * Zoon
                ElseIf i = _hotItem + 1 Then
                    t = Zoon
                Else
                    t = 0
                End If
                Dim rect As New Rectangle(x, y, Width, ItemHeight + t)
                y += rect.Height
                '绘制背景
                Using bgSB As New LinearGradientBrush(rect, Color.White, clr1, LinearGradientMode.Vertical)
                    g.FillRectangle(bgSB, rect)
                End Using
                g.DrawRectangle(bkP, rect)

                '绘制图白哦
                Dim image As Image = Imagelist.Images(Items(i).ImageIndex)
                If image IsNot Nothing Then
                    Dim r As New Rectangle(2, rect.Y + 2, rect.Height - 4, rect.Height - 4)
                    g.DrawImage(image, r)
                End If
                '绘制文字
                Dim txtRect As New Rectangle(rect.Height, rect.Y, rect.Width - rect.Height, rect.Height)
                g.DrawString(Items(i).Text, Font, Brushes.Black, txtRect, sf)

            Next
        End Sub
        Protected Overrides Sub OnPaint(ByVal e As System.Windows.Forms.PaintEventArgs)
            If DesignMode Then
                Dim rect As New Rectangle(0, 0, Width - 1, Height - 1)
                e.Graphics.FillRectangle(Brushes.White, rect)
                e.Graphics.DrawRectangle(New Pen(Color.FromArgb(59, 163, 218)), rect)
                Return
            End If
            ' testpaint(e)
            If Items.Count = 0 Then
                MyBase.OnPaint(e)
                Return
            End If
            '计算起始行和结束行，都加上1 防止绘制缺欠
            Dim startI As Int32 = VerticalScroll.Value / ItemHeight - 1
            Dim finishI As Int32 = (VerticalScroll.Value + ClientSize.Height) / ItemHeight + 1
            startI = Math.Max(startI, 0)
            finishI = Math.Min(finishI, Items.Count - 1)

            Dim g As Graphics = e.Graphics
            g.SmoothingMode = SmoothingMode.HighQuality
            g.TranslateTransform(AutoScrollPosition.X, AutoScrollPosition.Y)

            Dim y As Int32 = 0
            Dim x As Int32 = 1
            Dim w As Int32 = Width
            Dim h As Int32 = ItemHeight
            Dim scrollW As Int32 = 0
            If AutoScrollMinSize.Height > ClientSize.Height Then scrollW = 18
            Dim blnImage As Boolean = _Imagelist IsNot Nothing

            Dim bkclr As Color = Color.FromArgb(198, 211, 227)
            Dim clr1 As Color = Color.FromArgb(235, 244, 245)

            ' Dim bgSB As LinearGradientBrush
            Dim bkP As New Pen(bkclr)
            Dim sf As New StringFormat
            sf.Alignment = StringAlign
            sf.LineAlignment = StringAlignment.Center

            If startI = 0 Then
                y = 0
            ElseIf startI = _hotItem Then
                y = ItemHeight * (startI + 0) + Zoon
            ElseIf startI - _hotItem > 1 Then
                y = ItemHeight * (startI + 0) + 3 * Zoon
            ElseIf startI - _hotItem > 2 Then
                y = ItemHeight * (startI + 0) + 4 * Zoon
            Else
                y = ItemHeight * (startI + 0)
            End If
            'If startI = _hotItem Then
            '    y = ItemHeight * (startI + 0) + Zoon
            'Else
            '    y = ItemHeight * (startI + 0)
            'End If

            For i As Int32 = startI To finishI
                Dim rect As Rectangle

                If i = _hotItem - 1 Then
                    rect = New Rectangle(x, y, w, h + Zoon)
                ElseIf i = _hotItem Then
                    rect = New Rectangle(x, y, w, h + 2 * Zoon)
                ElseIf i = _hotItem + 1 Then
                    rect = New Rectangle(x, y, w, h + Zoon)
                Else
                    rect = New Rectangle(x, y, w, h)
                End If

                If i = _hotItem Then
                    clr1 = Color.Orange
                Else
                    clr1 = Color.FromArgb(235, 244, 245)
                End If

                '绘制背景
                Using bgSB As New LinearGradientBrush(rect, Color.White, clr1, LinearGradientMode.Vertical)
                    g.FillRectangle(bgSB, rect)
                End Using
                g.DrawRectangle(bkP, rect)

                '绘制图白哦
                Dim image As Image = Imagelist.Images(Items(i).ImageIndex)
                If image IsNot Nothing Then
                    Dim r As New Rectangle(2, rect.Y + 2, rect.Height - 4, rect.Height - 4)
                    g.DrawImage(image, r)
                End If
                '绘制文字
                Dim txtRect As New Rectangle(rect.Height, rect.Y, rect.Width - rect.Height - scrollW, rect.Height)
                g.DrawString(Items(i).Text, Font, Brushes.Black, txtRect, sf)

                y += rect.Height
            Next
            g.TranslateTransform(-AutoScrollPosition.X, -AutoScrollPosition.Y)
            Using Pen As New Pen(Color.FromArgb(59, 163, 218))
                g.DrawRectangle(Pen, New Rectangle(0, 0, Width - 1, Height - 1))
            End Using

        End Sub

        ''' <summary>
        ''' 计算指定点所在item
        ''' </summary>
        ''' <param name="pt"></param>
        ''' <returns></returns>
        ''' <remarks></remarks>
        Public Function GetItemFromPoint(ByVal pt As Point) As Int32
            If Items.Count = 0 Then Return -1

            Dim index As Int32 = -1
            Dim curY As Int32 '当前热点所
            If _hotItem = 0 Then
                curY = 0
            Else
                curY = _hotItem * ItemHeight + Zoon '
            End If

            pt = pt - AutoScrollPosition
            '判断点在热点之前或者后
            If pt.Y < curY Then
                '在前面
                If pt.Y > curY - ItemHeight - Zoon Then '是否前一个
                    index = _hotItem - 1
                Else
                    Dim n As Int32 = Math.Ceiling(pt.Y / ItemHeight) 'Math.Ceiling((curY - ItemHeight - Zoon) / ItemHeight)
                    index = n ' - 1 ' _hotItem - n + 1

                End If
            Else
                '在后面
                '判断是否在源热点
                If pt.Y < (curY + ItemHeight + 2 * Zoon) Then
                    index = _hotItem
                ElseIf pt.Y < curY + ItemHeight * 2 + Zoon * 3 Then '是否在热点下一个
                    index = _hotItem + 1
                Else
                    Dim n As Int32 = pt.Y - (curY + ItemHeight + Zoon * 3)
                    index = Math.Ceiling((pt.Y - ItemHeight * 2 - Zoon * 3) / ItemHeight) + 1
                End If
            End If
            If index < 0 OrElse index > Items.Count - 1 Then
                index = -1
            End If

            Return index
        End Function

        Public Sub fnCaseSize()
            Dim w As Int32 = Width
            Dim h As Int32 = (ItemHeight * Items.Count + 0) + 4 * Zoon
            If h > ClientSize.Height Then w -= 18
            AutoScrollMinSize = New Size(w, h)
        End Sub
#End Region
    End Class
End Namespace

 

Namespace ListboxExNS


    <Serializable()> Public Class listitem
        Private _text As String
        Private _imageindex As Int32 = -1

        Sub New(ByVal text As String)
            _text = text
        End Sub
        Sub New(ByVal text As String, ByVal imageindex As Int32)
            _text = text
            _imageindex = imageindex
        End Sub

        Property Text() As String
            Get
                Return _text
            End Get
            Set(ByVal value As String)
                _text = value
            End Set
        End Property

        Property ImageIndex() As Int32
            Get
                Return _imageindex
            End Get
            Set(ByVal value As Int32)
                _imageindex = value
            End Set
        End Property

        Public Overrides Function ToString() As String
            Return Text
        End Function
    End Class

End Namespace

 

 

Namespace ListboxExNS

    Public Class ItemClickEventArgs
        Inherits EventArgs

        Sub New(ByVal item As listitem)
            _item = item
        End Sub

        Private _item As listitem
        Property Item() As listitem
            Get
                Return _item
            End Get
            Set(ByVal value As listitem)
                _item = value
            End Set
        End Property

    End Class

End Namespace

 

Namespace ListboxExNS

    ''' <summary>
    ''' 文本对齐方式
    ''' </summary>
    ''' <remarks></remarks>
    Public Enum StringAlign
        ''' <summary>
        ''' 左对齐
        ''' </summary>
        ''' <remarks></remarks>
        left = 0
        ''' <summary>
        ''' 中间对齐
        ''' </summary>
        ''' <remarks></remarks>
        center = 1
        ''' <summary>
        ''' 右对齐
        ''' </summary>
        ''' <remarks></remarks>
        right = 2
    End Enum

End Namespace