Option Explicit

Rem   Author Belayev Danila [outen@mail.ru]
Rem   Автор Беляев Данила [outen@mail.ru]

'********************************************************************
'*              Дописано в 2002 году (Team HomeWork)                *
'*                      e-mail: sne_pro@mail.ru                     *
'********************************************************************

Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const Square = &H1 Or &H2 Or &H4 Or &H8

Public Enum gbBorderStyle
    lBrStlNone = 0
    lBrStlNormalDwn = 2
    lBrStlNormalUp = 4
    lBrStlStandartUp = 5
    lBrStlFrameSt1 = 6
    lBrStlFrameSt2 = 9
    lBrStlStandartDwn = 10
End Enum
Public Enum Align
    lstAgLeft = 0
    lstAgCenter = 1
    lstAgRight = 2
End Enum
Public Enum Style
    lstFntNormal = 0
    lstFntBold = 1
    lstFntItalic = 2
End Enum
Public Enum gbLstPicMode
    lstMdFill = 0
    lstMdStretch = 1
    lstMdNormal = 2
End Enum
Private Type LstItem
    strItem     As String
    lngIcon     As Picture
    lngStyle    As Style
    lngAlign    As Align
    sTag        As String
End Type
Private Type RECT
    lngLeft     As Long
    lngTop      As Long
    lngRight    As Long
    lngBottom   As Long
End Type

Private ArrItem() As LstItem
Private lngSelected As Long, lngPos As Long, lngBrush As Long, rctRect As RECT, m_PicMode As Long, _
        m_Style As gbBorderStyle, m_GetStrUnCur As String, qrc As RECT, m_WithIcons As Boolean

Public Event Change()
Public Event Click()
Public Event DblClick()
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 KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)

Public Sub Add(ByVal strString As String, Optional ByVal lngIcon As Picture, Optional lngStyle As Style, Optional lngAlign As Align, Optional ByVal strTag As String)
    If Count = &HFFFF Then
        ReDim ArrItem(0)
    Else
        ReDim Preserve ArrItem(UBound(ArrItem) + vbNull)
    End If

    With ArrItem(Count)
        Set .lngIcon = lngIcon

        .strItem = strString
        .lngStyle = lngStyle
        .lngAlign = lngAlign
        .sTag = strTag
    End With

    RaiseEvent Change
End Sub

Public Sub Remove(ByVal lngIndex As Long)
    Dim ub As Long
    ub = Count
    
    If ub = &HFFFF Then Exit Sub

    If ub = 0& Then
        Call Clear
    Else
        For ub = lngIndex To ub - vbNull
            ArrItem(ub) = ArrItem(ub + vbNull)
        Next

        ReDim Preserve ArrItem(ub - vbNull)
    End If

    If lngSelected >= ub Then lngSelected = ub - vbNull

    Call Update
    RaiseEvent Change
End Sub

Public Sub Clear()
    Erase ArrItem
    lngSelected = 0
End Sub

Public Function Count() As Long
    On Error Resume Next
    Count = &HFFFF
    Count = UBound(ArrItem)
End Function

Public Function MaxPos() As Long
    MaxPos = Count + vbNull - UserControl.ScaleHeight / UserControl.TextHeight(vbNullString)
End Function

Public Sub Update()
    Dim i As Long, OldColor As Long
    
    Call UserControl.Cls                                                    ' Готовимся
    Call GetClientRect(UserControl.hWnd, qrc)
    Call DrawEdge(UserControl.hdc, qrc, m_Style, Square)

    If UserControl.Picture Then                                             ' Фон
        Select Case PicMode
            Case Is = lstMdFill
                Call FillRect(UserControl.hdc, rctRect, lngBrush)
            Case Is = lstMdNormal
                '
            Case Is = lstMdStretch
                Call PaintPicture(Me.Picture, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight)
        End Select
    End If
    If Not Count = &HFFFF Then
        Line (IIf(m_WithIcons, 20, 2), _
             lngSelected - lngPos) * UserControl.TextHeight(vbNullString))- _
             UserControl.ScaleWidth, (lngSelected - lngPos) * UserControl.TextHeight(vbNullString) + UserControl.TextHeight(vbNullString)), _
              GetSysColor(13), BF
    End If
    UserControl.CurrentY = 0&

    For i = lngPos To lngPos + UserControl.ScaleHeight \ UserControl.TextHeight(vbNullString)
        If i > Count Or i = &HFFFF Then Exit For
                                                                            ' Шрифт
        UserControl.FontBold = ((ArrItem(i).lngStyle And lstFntBold) = lstFntBold)
        UserControl.FontItalic = ((ArrItem(i).lngStyle And lstFntItalic) = lstFntItalic)

        Select Case ArrItem(i).lngAlign                                     ' Выравнивание
            Case Is = lstAgCenter: UserControl.CurrentX = (UserControl.ScaleWidth \ 2) - (UserControl.TextWidth(ArrItem(i).strItem) \ 2) + IIf(m_WithIcons, &H10 / 2, 0&
            Case Is = lstAgRight:  UserControl.CurrentX = UserControl.ScaleWidth - UserControl.TextWidth(ArrItem(i).strItem)
            Case Is = lstAgLeft:   UserControl.CurrentX = IIf(m_WithIcons, &H14, 0&  ' 16 + 2
        End Select

        If Not ArrItem(i).lngIcon Is Nothing And m_WithIcons Then
            Call PaintPicture(ArrItem(i).lngIcon, 2, UserControl.CurrentY, 16, 16)
            If UserControl.CurrentX < &H14 Then UserControl.CurrentX = &H14     ' Нельзя заехать на иконку
        Else
            If UserControl.CurrentX < 2& Then UserControl.CurrentX = 2&     ' Нельзя заехать на иконку
        End If

        If i = lngSelected Then                                             ' Текст
            OldColor = UserControl.ForeColor
            UserControl.ForeColor = GetSysColor(14)

            Print ArrItem(i).strItem
            UserControl.ForeColor = OldColor
        Else
            Print ArrItem(i).strItem
        End If
    Next
                                                                            ' Края
    Call DrawEdge(hdc, qrc, m_Style, Square)
End Sub

' §§§§§§§§§§§§§§§§§§§§§§§§§§  §§§§§§§§§§§§§§§§§§§§§§§§§§

Public Property Get Pos() As Long
    Pos = lngPos
End Property
Public Property Let Pos(ByVal lngNewPos As Long)
    lngPos = lngNewPos
    Call Update
End Property

Public Property Get Selected() As Long
    Selected = lngSelected
End Property
Public Property Let Selected(ByVal lngNewSelected As Long)
    On Error Resume Next

    If Count = &HFFFF Then Exit Property
    If lngSelected < 0 Then Selected = 0
    If lngSelected > Count Then Selected = Count

    lngSelected = lngNewSelected

    Call Update
End Property

Public Property Get Style() As gbBorderStyle
    Style = m_Style
End Property
Public Property Let Style(New_Style As gbBorderStyle)
    m_Style = New_Style
    Call Update
End Property

Public Property Get Item(ByVal lngIndex As Long) As String
    Item = ArrItem(lngIndex).strItem
End Property
Public Property Let Item(ByVal lngIndex As Long, strItem As String)
    ArrItem(lngIndex).strItem = strItem
    If lngIndex >= lngPos And lngIndex <= lngPos + UserControl.ScaleHeight \ UserControl.TextHeight(vbNullString) Then Call Update
End Property

Public Property Get ItemTag(ByVal lngIndex As Long) As String
    ItemTag = ArrItem(lngIndex).sTag
End Property
Public Property Let ItemTag(ByVal lngIndex As Long, strItemTag As String)
    ArrItem(lngIndex).sTag = strItemTag
End Property

Public Property Get Picture() As Picture
    Set Picture = UserControl.Picture
End Property
Public Property Set Picture(ByVal New_Picture As Picture)
    Set UserControl.Picture = New_Picture
    PropertyChanged "Picture"
    lngBrush = CreatePatternBrush(Picture)
    Call Update
End Property

Public Property Get PicMode() As gbLstPicMode
    PicMode = m_PicMode
End Property
Public Property Let PicMode(ByVal New_Value As gbLstPicMode)
    m_PicMode = New_Value
    Call Update
End Property

Public Property Get BackColor() As OLE_COLOR
    BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
    Call Update
End Property

Public Property Get Font() As Font
    Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
    Call Update
End Property

Public Property Get ForeColor() As OLE_COLOR
    ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    UserControl.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
    Call Update
End Property

Public Property Get WithIcons() As Boolean
    WithIcons = m_WithIcons
End Property
Public Property Let WithIcons(ByVal New_WithIcons As Boolean)
    m_WithIcons = New_WithIcons
    PropertyChanged "WithIcons"
    Call Update
End Property

Public Property Get GetStrUnCur() As String
    GetStrUnCur = m_GetStrUnCur
End Property

Public Property Get hWnd() As Long
    hWnd = UserControl.hWnd
End Property

' §§§§§§§§§§§§§§§§§§§§§§§§§§  §§§§§§§§§§§§§§§§§§§§§§§§§§

Private Sub UserControl_KeyDown(Key As Integer, Shift As Integer)
    Select Case Key
        Case vbKeyUp
            If lngSelected > 0 Then Selected = lngSelected - vbNull
            If lngSelected < lngPos Then lngPos = lngPos - vbNull

        Case vbKeyDown
            If lngSelected < Count Then Selected = lngSelected + vbNull
            If lngSelected > lngPos - vbNull + UserControl.ScaleHeight \ UserControl.TextHeight(vbNullString) Then lngPos = lngPos + vbNull
        
        Case vbKeyHome
            lngSelected = 0
            lngPos = 0
        
        Case vbKeyEnd
            lngSelected = Count
            If MaxPos < 0 Then Exit Sub
            lngPos = MaxPos
        
        Case vbKeyReturn
            RaiseEvent Click
        
        Case vbKeyPageUp
            lngPos = IIf(Not lngPos - Fix(UserControl.ScaleHeight / UserControl.TextHeight(vbNullString)) < 0, lngPos - Fix(UserControl.ScaleHeight / UserControl.TextHeight(vbNullString)), 0)
            Selected = lngPos
        
        Case vbKeyPageDown
            If lngPos + Fix(UserControl.ScaleHeight / UserControl.TextHeight(vbNullString)) < MaxPos Then
                lngPos = lngPos + Fix(UserControl.ScaleHeight / UserControl.TextHeight(vbNullString))
                Selected = lngPos + Fix(UserControl.ScaleHeight / UserControl.TextHeight(vbNullString)) - vbNull
            Else
                lngPos = MaxPos: lngSelected = Count
            End If
    End Select
    Call Update

    RaiseEvent KeyDown(Key, Shift)
End Sub

Private Sub UserControl_Click()
    If Count = &HFFFF Then Exit Sub
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    If Count = &HFFFF Then Exit Sub
    RaiseEvent DblClick
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    If Count = &HFFFF Then Exit Sub
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    If Count = &HFFFF Then Exit Sub
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If (Y \ UserControl.TextHeight(vbNullString)) + lngPos > Count Then Exit Sub
    Selected = (Y \ UserControl.TextHeight(vbNullString)) + lngPos

    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Count = &HFFFF Or Y < 0 Then Exit Sub
    If Not (Y \ UserControl.TextHeight(vbNullString)) + lngPos > Count Then m_GetStrUnCur = ArrItem((Y \ UserControl.TextHeight(vbNullString)) + lngPos).strItem

    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Count = &HFFFF Or Y < 0 Then Exit Sub
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

' §§§§§§§§§§§§§§§§§§§§§§§§§§  §§§§§§§§§§§§§§§§§§§§§§§§§§

Private Sub UserControl_Resize()
    Call GetClientRect(UserControl.hWnd, rctRect)
    Call Update
End Sub

Private Sub UserControl_Show()
    Call Update
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Set Picture = PropBag.ReadProperty("Picture", Nothing)
    m_PicMode = PropBag.ReadProperty("PicMode", 0&
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    m_Style = PropBag.ReadProperty("Style", 0)
    m_WithIcons = PropBag.ReadProperty("WithIcons", False)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Picture", Picture, Nothing)
    Call PropBag.WriteProperty("PicMode", PicMode, 0&
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H80000005)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Style", m_Style, 0)
    Call PropBag.WriteProperty("WithIcons", m_WithIcons, False)
End Sub

Private Sub UserControl_InitProperties()
    Set UserControl.Font = Ambient.Font
End Sub

Option Explicit

Private Sub Command1_Click()
    Call Lst1.Remove(Lst1.Selected)
    Call Lst1.Update
End Sub

Private Sub Command2_Click()
    Lst1.WithIcons = Not Lst1.WithIcons
End Sub

Private Sub Command3_Click()
    If Lst1.PicMode = 2 Then Lst1.PicMode = 0: Exit Sub
    Lst1.PicMode = Lst1.PicMode + vbNull
End Sub

Private Sub Form_Load()
    Dim i As Long
    
    Call Randomize(Timer)
    
    For i = 0 To 100
        Call Lst1.Add("str #" & i, Me.Icon, lstFntNormal, lstAgLeft, "Таг к каждому эллементу в списке " & i)
    Next

    Lst1.WithIcons = True
    Call Lst1.Update
End Sub

Private Sub Lst1_Change()
    VScroll1.Max = Lst1.MaxPos + 1
End Sub

Private Sub Lst1_DblClick()
    MsgBox Lst1.ItemTag(Lst1.Selected)
End Sub

Private Sub Lst1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Label1.Caption = Lst1.GetStrUnCur
End Sub

Private Sub VScroll1_Scroll()
    Lst1.Pos = VScroll1.Value
End Sub

If UserControl.Picture Then                                             ' Фон
        Select Case PicMode
            Case Is = lstMdFill
                Call FillRect(UserControl.hdc, rctRect, lngBrush)
            Case Is = lstMdNormal
                '
            Case Is = lstMdStretch
                Call PaintPicture(Me.Picture, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight)
        End Select
    End If