boundcombo.ctl

《VB6数据库开发指南》所有的例程的源码

VERSION 5.00
Begin VB.UserControl ctlBoundCombo 
   ClientHeight    =   435
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2685
   ScaleHeight     =   435
   ScaleWidth      =   2685
   Begin VB.ComboBox cmbCodeValue 
      Height          =   315
      Left            =   0
      TabIndex        =   0
      Text            =   "Bound Combo"
      Top             =   0
      Width           =   2415
   End
End
Attribute VB_Name = "ctlBoundCombo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'Default Property Values:
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
Const m_def_strCodeType = ""
'Property Variables:
Dim m_BackStyle As Integer
Dim m_BorderStyle As Integer
Dim m_objDatabase As Object
Dim m_strCodeType As String
'Event Declarations:
Event Change() 'MappingInfo=cmbCodeValue,cmbCodeValue,-1,Change
Event Click() 'MappingInfo=cmbCodeValue,cmbCodeValue,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick() 'MappingInfo=cmbCodeValue,cmbCodeValue,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=cmbCodeValue,cmbCodeValue,-1,KeyDown
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=cmbCodeValue,cmbCodeValue,-1,KeyPress
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=cmbCodeValue,cmbCodeValue,-1,KeyUp
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
'Event Change()

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = cmbCodeValue.BackColor
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = cmbCodeValue.ForeColor
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,Enabled
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
    Enabled = cmbCodeValue.Enabled
End Property

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

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

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

Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "Indicates whether a Label or the background of a Shape is transparent or opaque."
    BackStyle = m_BackStyle
End Property

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

Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
    BorderStyle = m_BorderStyle
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,Refresh
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
    cmbCodeValue.Refresh
End Sub


Private Sub cmbCodeValue_Change()
    RaiseEvent Change
    
    ' Notify the container of data change
    PropertyChanged "Text"
    
End Sub

Private Sub cmbCodeValue_Click()
    RaiseEvent Click
    PropertyChanged "Text"
End Sub

Private Sub cmbCodeValue_DblClick()
    RaiseEvent DblClick
End Sub

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

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

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,ListCount
Public Property Get ListCount() As Integer
Attribute ListCount.VB_Description = "Returns the number of items in the list portion of a control."
    ListCount = cmbCodeValue.ListCount
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,ListIndex
Public Property Get ListIndex() As Integer
Attribute ListIndex.VB_Description = "Returns/sets the index of the currently selected item in the control."
    ListIndex = cmbCodeValue.ListIndex
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,Style
Public Property Get Style() As Integer
Attribute Style.VB_Description = "Returns/sets a value that determines the type of control and the behavior of its list box portion."
    Style = cmbCodeValue.Style
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=cmbCodeValue,cmbCodeValue,-1,Text
Public Property Get Text() As String
Attribute Text.VB_Description = "Returns/sets the text contained in the control."
Attribute Text.VB_MemberFlags = "3c"
    Text = cmbCodeValue.Text
End Property

Public Property Let Text(ByVal New_Text As String)
    If CanPropertyChange("Text") Then
        cmbCodeValue.Text() = New_Text
        PropertyChanged "Text"
    End If
End Property

Public Property Get objDatabase() As Object
    Set objDatabase = m_objDatabase
End Property

Public Property Set objDatabase(ByVal New_objDatabase As Object)
    
    Set m_objDatabase = New_objDatabase
    PropertyChanged "objDatabase"
    
    ' Set the object database and invoke the Reload method to
    ' put data into the combo box
    If "" <> strCodeType Then
        Call Reload
    End If
    
End Property

Public Property Get strCodeType() As String
    strCodeType = m_strCodeType
End Property

Public Property Let strCodeType(ByVal New_strCodeType As String)
    m_strCodeType = New_strCodeType
    PropertyChanged "strCodeType"
End Property

Public Sub Reload()
' Reload the combo box
Dim strSql As String
Dim rsCodes As Recordset

    cmbCodeValue.Clear
    ' If the code type has been set
    If "" <> strCodeType Then
        ' Build an SQL statement.
        strSql = "SELECT CodeValue10 FROM Code10 WHERE " _
                    & "CodeType10 = '" & strCodeType _
                    & "' ORDER BY CodeValue10"
        'Get a recordset.
        Set rsCodes = objDatabase.OpenRecordset(strSql, _
                        vbRSTypeSnapShot, dbForwardOnly)
        Do While Not rsCodes.EOF
            ' Add the items.
            cmbCodeValue.AddItem "" & rsCodes("CodeValue10")
            rsCodes.MoveNext
        Loop
    End If
    
    'Close the recordset
    rsCodes.Close
    
    Exit Sub
    
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_BackStyle = m_def_BackStyle
    m_BorderStyle = m_def_BorderStyle
    m_strCodeType = m_def_strCodeType
    
End Sub

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

    cmbCodeValue.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
    cmbCodeValue.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    cmbCodeValue.Enabled = PropBag.ReadProperty("Enabled", True)
    Set Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    cmbCodeValue.ListIndex = PropBag.ReadProperty("ListIndex", 0)
    cmbCodeValue.Text = PropBag.ReadProperty("Text", "Bound Combo")
    Set m_objDatabase = PropBag.ReadProperty("objDatabase", Nothing)
    m_strCodeType = PropBag.ReadProperty("strCodeType", m_def_strCodeType)
End Sub

Private Sub UserControl_Resize()
' Resize the combo box to the size of the control

    ' The height can't be changed for certain styles, so
    ' we won't support any height changes.
    Height = cmbCodeValue.Height
    ' Resize the combo box without using the Move method.
    cmbCodeValue.Top = 0
    cmbCodeValue.Left = 0
    cmbCodeValue.Width = ScaleWidth

End Sub

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

    Call PropBag.WriteProperty("BackColor", cmbCodeValue.BackColor, &H80000005)
    Call PropBag.WriteProperty("ForeColor", cmbCodeValue.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Enabled", cmbCodeValue.Enabled, True)
    Call PropBag.WriteProperty("Font", Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("ListIndex", cmbCodeValue.ListIndex, 0)
    Call PropBag.WriteProperty("Text", cmbCodeValue.Text, "Bound Combo")
    Call PropBag.WriteProperty("objDatabase", m_objDatabase, Nothing)
    Call PropBag.WriteProperty("strCodeType", m_strCodeType, m_def_strCodeType)
End Sub