glist.ctl

很好！ 很实用！ 免费！

VERSION 5.00
Begin VB.UserControl GList 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.ListBox List1 
      Height          =   2010
      Left            =   720
      TabIndex        =   0
      Top             =   600
      Width           =   2055
   End
End
Attribute VB_Name = "GList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Dim dicItem As Scripting.Dictionary
Dim m_NewIndex As Long
'Event Declarations:
Event Click() 'MappingInfo=List1,List1,-1,Click
Event DblClick() 'MappingInfo=List1,List1,-1,DblClick
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=List1,List1,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=List1,List1,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=List1,List1,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=List1,List1,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=List1,List1,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=List1,List1,-1,MouseUp
Dim m_DicDataID As Long

Private Function DicDataID() As String
    m_DicDataID = m_DicDataID + 1
    DicDataID = CStr(m_DicDataID)
End Function


Private Sub UserControl_Initialize()
    Set dicItem = New Scripting.Dictionary
    m_NewIndex = -1
End Sub

Private Sub UserControl_Resize()
    List1.Left = 0
    List1.Top = 0
    List1.Width = UserControl.Width
    List1.Height = UserControl.Height
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
    BackColor = List1.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    List1.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = List1.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    List1.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Enabled
Public Property Get Enabled() As Boolean
    Enabled = List1.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    List1.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property


'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackStyle
Public Property Get BackStyle() As Integer
    BackStyle = UserControl.BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    UserControl.BackStyle() = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BorderStyle
Public Property Get BorderStyle() As Integer
    BorderStyle = UserControl.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    UserControl.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Refresh
Public Sub Refresh()
    List1.Refresh
End Sub

Private Sub List1_Click()
    RaiseEvent Click
End Sub

Private Sub List1_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

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

Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,AddItem
Public Sub AddItem(ByVal Item As String)
    List1.AddItem Item
    m_NewIndex = List1.NewIndex
    List1.ItemData(m_NewIndex) = DicDataID()
End Sub
Public Sub RelativeList(ByRef p_Rs As ADODB.Recordset, ByVal p_TextName As String, Optional ByVal p_TextDetach As String = "--")
Dim i As Integer
Dim j As Integer
Dim index As Long
Dim arrText() As String
Dim sText As String
    If Not p_Rs.BOF Then p_Rs.MoveFirst
    arrText = Split(p_TextName, ",")
    
    For i = 0 To p_Rs.RecordCount - 1
        sText = ""
        For j = 0 To UBound(arrText)
            sText = sText + CStr(p_Rs.Fields(Trim(arrText(j))).value)
            If j < UBound(arrText) Then
                sText = sText + p_TextDetach
            End If
        Next j
        
        List1.AddItem sText
        
        index = DicDataID
        
        
        List1.ItemData(List1.NewIndex) = index

        For j = 0 To p_Rs.Fields.Count - 1
            dicItem.Add UCase(p_Rs.Fields(j).Name) + "A" + CStr(index) + "A", p_Rs.Fields(j).value
        Next j
        p_Rs.MoveNext
    Next i
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Clear
Public Sub Clear()
    dicItem.RemoveAll
    List1.Clear
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,List
Public Property Get List(ByVal index As Integer) As String
    List = List1.List(index)
End Property

Public Property Let List(ByVal index As Integer, ByVal New_List As String)
    List1.List(index) = New_List
    PropertyChanged "List"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,ListCount
Public Property Get ListCount() As Integer
    ListCount = List1.ListCount
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,ListIndex
Public Property Get ListIndex() As Integer
    ListIndex = List1.ListIndex
End Property

Public Property Let ListIndex(ByVal New_ListIndex As Integer)
    List1.ListIndex() = New_ListIndex
    PropertyChanged "ListIndex"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,NewIndex
Public Property Get NewIndex() As Long
    NewIndex = m_NewIndex
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Size
Public Sub Size(ByVal Width As Single, ByVal Height As Single)
    UserControl.Size Width, Height
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Sorted
Public Property Get Sorted() As Boolean
    Sorted = List1.Sorted
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Text
Public Property Get Text() As String
    Text = List1.Text
End Property

Public Property Let Text(ByVal New_Text As String)
    List1.Text() = New_Text
    PropertyChanged "Text"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Style
Public Property Get Style() As Integer
    Style = List1.Style
End Property


'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,ItemData
Public Property Get ItemData(ByVal index As Integer) As String
Dim sFieldName  As String
    sFieldName = UCase("ListItemData")
    
    If dicItem.Exists(Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A") Then
       ItemData = dicItem.Item(Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A")
    Else
       ItemData = Empty
    End If
End Property
Public Property Let ItemData(ByVal index As Integer, ByVal New_Item As String)
Dim sFieldName  As String
    sFieldName = UCase("ListItemData")
    
    If dicItem.Exists(Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A") Then
       dicItem.Item(Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A") = New_Item
    Else
       dicItem.Add Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A", New_Item
    End If
End Property

Public Property Get Item(ByVal sFieldName As String, Optional ByVal index As Integer = -1) As Variant
    If index = -1 Then
       index = List1.ListIndex
    End If

    sFieldName = Trim(UCase(sFieldName))

    If dicItem.Exists(sFieldName + "A" + CStr(List1.ItemData(index)) + "A") Then
       Item = dicItem.Item(sFieldName + "A" + CStr(List1.ItemData(index)) + "A")
    Else
       Item = Empty
    End If
End Property

Public Property Let Item(ByVal sFieldName As String, Optional ByVal index As Integer = -1, ByVal New_Item As Variant)
    If index = -1 Then
       index = List1.ListIndex
    End If
    sFieldName = UCase(sFieldName)
    
    If dicItem.Exists(Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A") Then
       dicItem.Item(Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A") = New_Item
    Else
       dicItem.Add Trim(sFieldName) + "A" + CStr(List1.ItemData(index)) + "A", New_Item
    End If
End Property

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim index As Integer

    List1.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    List1.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    List1.Enabled = PropBag.ReadProperty("Enabled", True)
    UserControl.BackStyle = PropBag.ReadProperty("BackStyle", 1)
    UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
    
    'List1.List(Index) = PropBag.ReadProperty("List" & Index, "")
    List1.ListIndex = PropBag.ReadProperty("ListIndex", -1)
    List1.Text = PropBag.ReadProperty("Text", "")
'TO DO: The member you have mapped to contains an array of data.
'   You must supply the code to persist the array.  A prototype
'   line is shown next:
    List1.Appearance = PropBag.ReadProperty("Appearance", 1)
End Sub

Private Sub UserControl_Terminate()
    Set dicItem = Nothing
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Dim index As Integer

    Call PropBag.WriteProperty("BackColor", List1.BackColor, &H80000005)
    Call PropBag.WriteProperty("ForeColor", List1.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Enabled", List1.Enabled, True)
    Call PropBag.WriteProperty("BackStyle", UserControl.BackStyle, 1)
    Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
'    Call PropBag.WriteProperty("List" & index, List1.List(index), "")
    Call PropBag.WriteProperty("ListIndex", List1.ListIndex, -1)
'    Call PropBag.WriteProperty("Text", List1.Text, "")
'TO DO: The member you have mapped to contains an array of data.
'   You must supply the code to persist the array.  A prototype
'   line is shown next:
    Call PropBag.WriteProperty("Appearance", List1.Appearance, 1)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,RemoveItem
Public Sub RemoveItem(ByVal index As Integer)
Dim iData As String
Dim i As Integer
    iData = CStr(List1.ItemData(index))
    For i = dicItem.Count - 1 To 0 Step -1
        If InStrRev(dicItem.Keys(i), "A" + iData + "A") > 0 Then
            dicItem.Remove dicItem.Keys(i)
        End If
    Next i
    List1.RemoveItem index
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,SelCount
Public Property Get SelCount() As Integer
    SelCount = List1.SelCount
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Selected
Public Property Get Selected(ByVal index As Integer) As Boolean
    Selected = List1.Selected(index)
End Property

Public Property Let Selected(ByVal index As Integer, ByVal New_Selected As Boolean)
    List1.Selected(index) = New_Selected
    PropertyChanged "Selected"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=List1,List1,-1,Appearance
Public Property Get Appearance() As Integer
    Appearance = List1.Appearance
End Property

Public Property Let Appearance(ByVal New_Appearance As Integer)
    List1.Appearance() = New_Appearance
    PropertyChanged "Appearance"
End Property