gcombo.ctl

来自「很好！ 很实用！ 免费！」· CTL 代码 · 共 576 行 · 第 1/2 页

VERSION 5.00
Begin VB.UserControl GCombo 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.ComboBox Combo1 
      Height          =   315
      Left            =   0
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   0
      Width           =   2775
   End
End
Attribute VB_Name = "GCombo"
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=Combo1,Combo1,-1,Click
Event DblClick() 'MappingInfo=Combo1,Combo1,-1,DblClick
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=Combo1,Combo1,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=Combo1,Combo1,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=Combo1,Combo1,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Event Change() 'MappingInfo=Combo1,Combo1,-1,Change
Event DropDown() 'MappingInfo=Combo1,Combo1,-1,DropDown
Event GetDataMember(DataMember As String, Data As Object) 'MappingInfo=UserControl,UserControl,-1,GetDataMember
Event Resize() 'MappingInfo=UserControl,UserControl,-1,Resize
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

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
        
        Combo1.AddItem sText
        
        index = DicDataID
        
        Combo1.ItemData(Combo1.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

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

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

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

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

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

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

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

Public Property Set Font(ByVal New_Font As Font)
    Set Combo1.Font = New_Font
    PropertyChanged "Font"
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=Combo1,Combo1,-1,Refresh
Public Sub Refresh()
    Combo1.Refresh
End Sub

Private Sub Combo1_Click()
    RaiseEvent Click
End Sub

Private Sub Combo1_DblClick()
    RaiseEvent DblClick
End Sub

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

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

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

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, x, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, x, Y)
End Sub

Private Sub UserControl_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=Combo1,Combo1,-1,AddItem
Public Sub AddItem(ByVal Item As String)
    Combo1.AddItem Item
    Combo1.ItemData(Combo1.NewIndex) = DicDataID
End Sub

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

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

Private Sub Combo1_Change()
    RaiseEvent Change
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Combo1,Combo1,-1,Clear
Public Sub Clear()
    dicItem.RemoveAll
    Combo1.Clear
End Sub
Public Property Get ItemData(ByVal index As Integer) As String
Dim sFieldName  As String
    sFieldName = UCase("ListItemData")
    
    If dicItem.Exists(Trim(sFieldName) + "A" + CStr(Combo1.ItemData(index)) + "A") Then
       ItemData = dicItem.Item(Trim(sFieldName) + "A" + CStr(Combo1.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(Combo1.ItemData(index)) + "A") Then
       dicItem.Item(Trim(sFieldName) + "A" + CStr(Combo1.ItemData(index)) + "A") = New_Item
    Else
       dicItem.Add Trim(sFieldName) + "A" + CStr(Combo1.ItemData(index)) + "A", New_Item
    End If
End Property
Private Sub UserControl_Terminate()
    Set dicItem = Nothing
End Sub



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

    sFieldName = Trim(UCase(sFieldName))

    If dicItem.Exists(sFieldName + "A" + CStr(Combo1.ItemData(index)) + "A") Then
       Item = dicItem.Item(sFieldName + "A" + CStr(Combo1.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 = Combo1.ListIndex
    End If
    sFieldName = UCase(sFieldName)
    
    If dicItem.Exists(Trim(sFieldName) + "A" + CStr(Combo1.ItemData(index)) + "A") Then
       dicItem.Item(Trim(sFieldName) + "A" + CStr(Combo1.ItemData(index)) + "A") = New_Item
    Else
       dicItem.Add Trim(sFieldName) + "A" + CStr(Combo1.ItemData(index)) + "A", New_Item
    End If
End Property

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

Public Property Let DrawStyle(ByVal New_DrawStyle As Integer)
    UserControl.DrawStyle() = New_DrawStyle
    PropertyChanged "DrawStyle"
End Property

Private Sub Combo1_DropDown()
    RaiseEvent DropDown
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Combo1,Combo1,-1,FontSize