clssupercbo.cls

来自「本系统可用于医院和专业体检中心的健康体检管理」· CLS 代码 · 共 104 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSuperCBO"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'类模块代码如下，取名：clsSuperCBO
Option Explicit

Private Const CB_SHOWDROPDOWN = &H14F
Private Const CB_SETCURSEL = &H14E

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

Public Event NeedRefreshForm()

Private bRun As Boolean
Private strArr() As String
Private WithEvents objComBox As ComboBox
Attribute objComBox.VB_VarHelpID = -1

Public Property Set CBO(objCBO As ComboBox)
    Set objComBox = objCBO
End Property

Public Sub AddStringToBuffer(ByVal strValue As String)
    Dim I As Long, K As Long, strT As String
    
    strT = LCase(strValue)
    K = BufferLength
    For I = 0 To K
        If LCase(strArr(I)) = strT Then
            Exit Sub
        End If
    Next
    K = K + 1
    ReDim Preserve strArr(K) As String
    strArr(K) = strValue
End Sub

Private Sub objComBox_Change()
    Dim strT As String, strValue As String
    Dim I As Long, K As Long
    
    If bRun = True Then
        Exit Sub
    End If
    bRun = True
    strValue = objComBox.Text
'    If Len(strValue) = 0 Then
'        bRun = False
'        Exit Sub
'    End If
    K = BufferLength
    If K = -1 Then
        bRun = False
        Exit Sub
    End If
    strT = LCase(strValue)
    
    With objComBox
        If .ListCount > 0 Then
            SendMessage .hwnd, CB_SHOWDROPDOWN, False, 0
'            For I = .ListCount - 1 To 0 Step -1
'                .RemoveItem I
'            Next I
'
            objComBox.Clear
            RaiseEvent NeedRefreshForm
        End If
        
        For I = 0 To K
            If LCase(strArr(I)) Like strT & "*" Then
                .AddItem strArr(I)
            End If
        Next
        
        SendMessage .hwnd, CB_SETCURSEL, -1, 0
        If .ListCount > 0 Then SendMessage .hwnd, CB_SHOWDROPDOWN, True, 0
        
        .Text = strValue
        .SelStart = Len(.Text)
    End With
    objComBox.Refresh
    RaiseEvent NeedRefreshForm
    bRun = False
End Sub

Public Property Get BufferLength() As Long
    On Error GoTo Err1:
    BufferLength = UBound(strArr)
    Exit Property
Err1:
    BufferLength = -1
End Property