xpcombo.ctl

VB 设计的排课管理系统,轻松解决排课难的问题！

VERSION 5.00
Begin VB.UserControl XPCombo 
   BackColor       =   &H00D8E9EC&
   BackStyle       =   0  '透明
   ClientHeight    =   3180
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4890
   EditAtDesignTime=   -1  'True
   LockControls    =   -1  'True
   ScaleHeight     =   3180
   ScaleWidth      =   4890
   Begin VB.PictureBox BackMain 
      Appearance      =   0  'Flat
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   465
      Left            =   0
      ScaleHeight     =   465
      ScaleWidth      =   2445
      TabIndex        =   1
      Top             =   0
      Width           =   2445
      Begin VB.TextBox JTexto 
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   0  'None
         Height          =   195
         Left            =   75
         TabIndex        =   3
         Text            =   "0"
         Top             =   60
         Width           =   720
      End
      Begin VB.PictureBox JImgCbo 
         Appearance      =   0  'Flat
         AutoSize        =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   840
         Picture         =   "XPCombo.ctx":0000
         ScaleHeight     =   255
         ScaleWidth      =   255
         TabIndex        =   2
         Top             =   30
         Width           =   255
      End
      Begin VB.Shape ShapeBorder 
         BorderColor     =   &H00B99D7F&
         Height          =   315
         Left            =   0
         Top             =   0
         Width           =   1125
      End
   End
   Begin VB.ComboBox JCombo 
      Height          =   300
      ItemData        =   "XPCombo.ctx":03B6
      Left            =   0
      List            =   "XPCombo.ctx":03B8
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   510
      Width           =   2295
   End
   Begin VB.Image Img 
      Height          =   255
      Index           =   3
      Left            =   0
      Picture         =   "XPCombo.ctx":03BA
      Top             =   900
      Width           =   255
   End
   Begin VB.Image Img 
      Height          =   255
      Index           =   2
      Left            =   0
      Picture         =   "XPCombo.ctx":0770
      Top             =   570
      Width           =   255
   End
   Begin VB.Image Img 
      Height          =   255
      Index           =   1
      Left            =   0
      Picture         =   "XPCombo.ctx":0B26
      Top             =   270
      Width           =   255
   End
   Begin VB.Image Img 
      Height          =   255
      Index           =   0
      Left            =   0
      Picture         =   "XPCombo.ctx":0EDC
      Top             =   0
      Width           =   255
   End
End
Attribute VB_Name = "XPCombo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/17
'描  述：XP风格下拉列表框
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
'.------------------------------------------------------------------
' Control   : JZ XP Combo Box 1.2
' Edition   : 13-May-2005
' Author    : JOZE Walter de Moura - RIO DE JANEIRO, BRASIL.
'           : me: www.joze.kit.net   or   [e-mail]
'           :
'           : Well, I've used basics on Combo Box "as XP"
'           : codes from several authors at Internet whose
'           : credits I acknowledge e appreciate.
'           :
'           : I've made a "brush up" certain routines and
'           : wrote all engines for TagCodes and Save/Load.
'           :
'Application: Another XP style Combo Box, but
'           : - as easy as TextBox programming: .Text, .Locked, etc.
'           : - a TagCode option allowing AddItens with leading
'           :   correlative data code, e.g., "US=United States" so
'           :   Combo lists is only "United States" and you can
'           :   retrieve "US" when selected by user.
'           : - A Save/Load engine using Text Files, notepadding
'           :   editable, so many applications as:
'           :   - Language and regional terminology supports;
'           :   - Small tables without DB;
'           :   - The same combo can get many text files - may be
'           :     a refined tree navigation.
'           :   - etc.
'           : - Maintenance functions to Append, Insert, Update and
'           :   Remove already loaded list items.
'           :
' License   : Freeware - you may distribute, alter, sold, anything
'           : as you want. This code is for you, don't it?
'           : I'm sure you will apply maximum of honesty and ethics
'           : concerning it.
'           :
' PS.       : TagCode treatment is limited to 100. If you need more,
'           : only to do is alter de MaxTCods constant value.
'           : Also, I've not improved other functions, as sort, auto-
'           : completes, etc., due avoiding "strong code".
'           :
'           : Joze.
'           :
' --------- :
' vers 1.2  : 16-May-2005
' --------- :
'           : Thanks a million to Territop (Paul) who have help to depure
'           : some bugs and suggest enhancements.
'           :
'  Enhances : 1. Function GetItem([index]) As String
'           :    Returns a string reflecting pointed Combo.List
'           :    If using TagCode then returns a string in format
'           :    "xxx=yyyy". i.e., TagCode & "=" & List.
'           :
'     Fixed : 1. MouseMove, MouseDown, KeyPress, KeyDown, KeyUp
'           :    for proper functions.
'           :
'           : 2. Bright effect on Combo Box Pick Botton now works ok.
'           :
'Know Errors: 1. When combo scrolling, in non-XP Windows, the
'           :    ScrollBar is not a Stylized "as XP".
'           :
'           :    Community Attention: I'd like your feedback if it
'           :    is a fundamental design adjust or not, and if
'           :    who had a nice and light suplemental code to do
'           :    this, ok?
'           :
'           : Thanks, Joze.
'           :
'`------------------------------------------------------------------'
Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Const CB_SHOWDROPDOWN = &H14F
Const CB_GETDROPPEDSTATE = &H157

'Events
Public Event Click()
Public Event Change()
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)

Const m_def_Enabled = 0
Const MaxTCods = 99

Dim m_Enabled As Boolean
Dim m_TagCode As Boolean
Dim m_FileName As String

Dim TCods(0 To MaxTCods) As String
Dim TLim As Long 'actual limit of array
Dim Tix As Long 'work pointer to array
Dim Titem As String
Dim TCod As String
Dim TTex As String
Dim m_Buf As String


Private Sub OpenCombo(chwnd As Long)
    Dim rc As Long
    rc = SendMessage(chwnd, CB_GETDROPPEDSTATE, 0, 0)
    If rc = 0 Then
        SendMessage chwnd, CB_SHOWDROPDOWN, True, 0
    Else
        SendMessage chwnd, CB_SHOWDROPDOWN, False, 0
    End If
    DoEvents
    ResetPic
End Sub

Private Sub RePos()
Dim i As Integer
    If Width < 400 Then Width = 400
    ShapeBorder.Width = Width
    JImgCbo.Left = Width - 285
    BackMain.Width = Width
    
    With JCombo
        .Top = 30
        .Left = 0
        .Width = Width
    End With
    
    Height = 315
    
    With JTexto
        .Width = Width - 375
        .Top = 60
        If .FontSize > 8 Then
            i = .FontSize - 8
            i = i * 15
            .Top = .Top - i
        End If
    End With
    
End Sub

Private Sub JCombo_Click()
    JTexto = JCombo.Text
End Sub

Private Sub JImgCbo_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    JImgCbo.Picture = Img(2).Picture
    OpenCombo JCombo.hWnd
End Sub

Private Sub JImgCbo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If JImgCbo.Picture <> Img(1).Picture Then JImgCbo.Picture = Img(1).Picture
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub JTexto_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(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 JTexto_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

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

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

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

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

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

Private Sub UserControl_Resize()
    RePos
End Sub

Public Property Get Text() As String
    Text = JTexto.Text
End Property

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

Public Property Get FileName() As String
   FileName = m_FileName
End Property

Public Property Let FileName(ByVal New_FileName As String)
   m_FileName = New_FileName
   PropertyChanged "FileName"
End Property

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

    JTexto.Text = PropBag.ReadProperty("Text", "0")
    JTexto.BackColor = PropBag.ReadProperty("BackColor", &HFFFFFF)
    Set JTexto.Font = PropBag.ReadProperty("Font", Ambient.Font)
    JTexto.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
    JCombo.ListIndex = PropBag.ReadProperty("ListIndex", -1)
    JTexto.Locked = PropBag.ReadProperty("Locked", False)
    JTexto.MaxLength = PropBag.ReadProperty("MaxLength", 0)
    JTexto.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
    JTexto.DataField = PropBag.ReadProperty("FieldName", "")
    
    RePos
    
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    m_TagCode = PropBag.ReadProperty("TagCode", False)
    m_FileName = PropBag.ReadProperty("FileName", "")

End Sub

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

    Call PropBag.WriteProperty("Text", JTexto.Text, "0")
    Call PropBag.WriteProperty("BackColor", JTexto.BackColor, &HFFFFFF)
    Call PropBag.WriteProperty("Font", JTexto.Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", JTexto.ForeColor, &H80000008)
    Call PropBag.WriteProperty("ListIndex", JCombo.ListIndex, -1)
    Call PropBag.WriteProperty("Locked", JTexto.Locked, False)
    Call PropBag.WriteProperty("MaxLength", JTexto.MaxLength, 0)
    Call PropBag.WriteProperty("ToolTipText", JTexto.ToolTipText, "")
    Call PropBag.WriteProperty("FieldName", JTexto.DataField, "")
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("TagCode", m_TagCode, False)
    Call PropBag.WriteProperty("SelStart", JTexto.SelStart, 0)
    Call PropBag.WriteProperty("SelLength", JTexto.SelLength, 0)
    Call PropBag.WriteProperty("SelText", JTexto.SelText, "")
    Call PropBag.WriteProperty("FileName", m_FileName, "")

End Sub

Sub ResetPic()
    If JImgCbo.Picture <> Img(0).Picture Then
        JImgCbo.Picture = Img(0).Picture
    End If
End Sub

Private Sub JTexto_Click()
    RaiseEvent Click
End Sub

Private Sub JTexto_Change()
   RaiseEvent Change
End Sub

Public Sub UpdateItem(Item As String, ByVal Index As Variant)
   If Index < 0 Or Index > JCombo.ListCount - 1 Then ' test bounds
      Exit Sub
   End If
   If m_TagCode = False Then 'normal
      JCombo.List(Index) = Item 'updates it as is
   Else
'TagCode is on
      If Index > MaxTCods Or Index > TLim Then 'tcodes limits
         JCombo.List(Index) = Item 'updates it as is
      Else
         Call IsTagCode(Item)
         JCombo.List(Index) = TTex 'updates combo segment
         Tix = CLng(Index) ' for coherence proposes only
         TCods(Tix) = TCod
      End If
   End If
   JTexto.Text = JCombo.Text
   RaiseEvent Change
End Sub

Public Sub AddItem(Item As String, Optional ByVal Index As Variant)
   If IsMissing(Index) Then
      PutItem Item
   Else
      If Index < 0 Then
         Index = 0
      End If
      If Index > JCombo.ListCount - 1 Then
         PutItem Item
      Else
         PutItem Item, Index
      End If
   End If
   JCombo.ListIndex = Tix
   JTexto.Text = JCombo.Text
   RaiseEvent Change
End Sub

Public Function GetItem(Optional Index As Variant) As String
   Dim i As Long
   Dim s As String
   If IsMissing(Index) Then
      If JCombo.ListCount > 0 Then
         i = JCombo.ListCount - 1
      Else
         GetItem = ""
         Exit Function
      End If
   Else
      i = CLng(Index)
      If i < 0 Then
         i = 0
      End If
   End If
   s = ""
   If m_TagCode = True Then
      s = TCods(i) & "="
   End If
   GetItem = s & JCombo.List(CInt(i)) 'maybe adjust code to future VB version
End Function

Public Sub RemoveItem(Optional Index As Variant)
   Dim i As Long
   If IsMissing(Index) Then
      If JCombo.ListCount > 0 Then
         i = JCombo.ListCount - 1
      Else
         Exit Sub
      End If
   Else
      i = CLng(Index)
      If i < 0 Then
         i = 0
      End If
   End If
   If m_TagCode = True Then
      RemoveTagCode i