by Cyrus Austria Lacaba (2 Submissions)
Category: OLE/COM/DCOM/Active-X
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sun 14th May 2006
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Auto - Select Combo Box for Quick Search
API Declarations
'Program Title:Auto Search Combo Box OCX
'Date : 9 May 2006, 10 May 2006
'Author: Cyrus Lacaba - Death ®
'Place: Las Piñas City, Philippines'
'Free to Edit and to Use
Option Explicit
Private m_DecimalEntry As Boolean
Private m_collection() As String
Private a As New Collection
Private b As New Collection
Private m_lngpopulated&
Private strconcat$
'-----------------------
Public Event Click()
Public Event DblClick()
VBcoders
Text = Combo1.Text
End Property
Public Property Let Text(ByVal NewValue As String)
Combo1.Text = NewValue
End Property
Private Sub Combo1_Click()
RaiseEvent Click
End Sub
Private Sub Combo1_DblClick()
RaiseEvent DblClick
End Sub
Public Property Get NewIndex() As Integer
NewIndex = Combo1.NewIndex
End Property
Public Property Let NewIndex(ByVal NewValue As Integer)
Combo1.NewIndex = NewValue
End Property
Public Property Get ItemData(ByVal Index As Integer) As Long
ItemData = Combo1.ItemData(Index)
End Property
Public Property Let ItemData(ByVal Index As Integer, ByVal NewValue As Long)
Combo1.ItemData(Index) = NewValue
End Property
Public Property Get ListIndex() As Long
ListIndex = Combo1.ListIndex
End Property
Public Property Let ListIndex(ByVal NewValue As Long)
Combo1.ListIndex = NewValue
End Property
Public Property Get ListCount() As Long
ListCount = Combo1.ListCount
End Property
Private Sub Combo1_KeyUp(KeyCode As Integer, Shift As Integer)
Static md&, i&, p&
Select Case KeyCode
Case vbKeyLButton, _
vbKeyRButton, _
vbKeyCancel, _
vbKeyMButton, _
vbKeyTab, _
vbKeyClear, _
vbKeyReturn, _
vbKeyShift, _
vbKeyControl, _
vbKeyMenu, _
vbKeyPause, _
vbKeyCapital, _
vbKeyEscape, _
vbKeySpace, _
vbKeyPageUp, _
vbKeyPageDown, _
vbKeyEnd, _
vbKeyHome, _
vbKeyLeft, _
vbKeyUp, _
vbKeyRight, _
vbKeyDown, _
vbKeySelect, _
vbKeyPrint
Exit Sub
Case vbKeyExecute, _
vbKeySnapshot, _
vbKeyInsert, _
vbKeyHelp, _
vbKeyNumlock, _
vbKeyF1, _
vbKeyF2, _
vbKeyF3, _
vbKeyF4, _
vbKeyF5, _
vbKeyF6, _
vbKeyF7, _
vbKeyF8, _
vbKeyF9, _
vbKeyF10, _
vbKeyF11, _
vbKeyF12, _
vbKeyF13, _
vbKeyF14, _
vbKeyF15, _
vbKeyF16
Exit Sub
End Select
If a.Count = 0 Then Exit Sub
strconcat$ = Combo1.Text
Set b = New Collection
If Combo1.Text <> vbNullString Then
If ClearCollectionB(b) = False Then Exit Sub
For i = 1 To a.Count
If InStr(1, a.Item(i), Combo1.Text) = 1 Then
b.Add a.Item(i)
End If
Next
m_lngpopulated = b.Count
Else
If ClearCollectionB(b) = False Then Exit Sub
Combo1.Clear
For i = 1 To a.Count
Combo1.AddItem a.Item(i)
Next
Exit Sub
End If
If b.Count = m_lngpopulated Then
If md& = 0 Then
Do While Combo1.ListCount <> 0
Combo1.RemoveItem Combo1.ListCount - 1
DoEvents
Loop
End If
For p = 1 To b.Count
Combo1.AddItem b.Item(p)
md& = 1
Next
If Combo1.ListCount <> 0 Then
Combo1.Text = Combo1.List(0)
Combo1.SelStart = Len(strconcat$)
Combo1.SelLength = Len(Combo1.Text) - 1
End If
If Combo1.ListCount = m_lngpopulated Then
md& = 0
End If
End If
End Sub
Private Sub UserControl_Initialize()
Combo1.Top = 0
Combo1.Left = 0
Combo1.Width = UserControl.Width
Combo1.Text = "Auto Select Combo by Cyrus ®"
'UserControl.Height = Combo1.Height + 500
End Sub
Private Sub UserControl_Resize()
Combo1.Top = 0
Combo1.Left = 0
Combo1.Width = UserControl.Width
UserControl.Height = Combo1.Height
End Sub
Private Function ClearCollectionB(m_collection As Collection) As Boolean
On Error GoTo ErrorHandler
Dim i&
For i = 1 To m_collection.Count
m_collection.Remove i
Next
ClearCollectionB = True
Exit Function
ErrorHandler:
ClearCollectionB = False
End Function
Public Sub RemoveItem(ByVal Index As Long)
Combo1.RemoveItem Index
a.Remove Index
End Sub
Public Sub AddItem(ByVal Item As String)
Combo1.AddItem Item
a.Add Item
End Sub
Public Sub Clear()
Combo1.Clear
Call ClearCollectionB(a)
End Sub
'Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
' RaiseEvent KeyDown(KeyCode, Shift)
'End Sub
'end of set font
'set mousepointer
Public Property Get MousePointer() As MousePointerConstants
MousePointer = UserControl.MousePointer
End Property
Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
' Validation is supplied by UserControl.
Let UserControl.MousePointer() = New_MousePointer
PropertyChanged "MousePointer"
End Property
'end of set mousepointer
'set mouseicon
Public Property Get MouseIcon() As Picture
Set MouseIcon = UserControl.MouseIcon
End Property
Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
Set UserControl.MouseIcon = New_MouseIcon
PropertyChanged "MouseIcon"
End Property
Public Property Get DecimalEntry() As Boolean
DecimalEntry = m_DecimalEntry
End Property
Public Property Let DecimalEntry(ByVal NewValue As Boolean)
m_DecimalEntry = NewValue
End Property
'Appended by Cyrus for Text Box Key Press
Private Sub KeyPress_Decimal(EntryType As Long, objControl As Control, KeyPress As Integer, Optional ByVal Places As Integer = 2)
If EntryType = 1 Then
If KeyPress = vbKeyBack Then Exit Sub
If Not (Chr(KeyPress) >= "0" And Chr(KeyPress) <= "9") And (Chr(KeyPress) <> ".") And (Chr(KeyPress) <> "-") Then
KeyPress = 0
End If
'Check for multiple occurence of "."
If Chr(KeyPress) = "." Then
If InStr(objControl.Text, ".") <> 0 Then
KeyPress = 0
End If
End If
If Chr(KeyPress) = "-" Then
If InStr(objControl.Text, "-") <> 0 Or objControl.SelStart <> 0 Then
KeyPress = 0
End If
End If 'Check for decimal places allow only 2
If InStr(objControl.Text, ".") <> 0 Then
If InStr(objControl.Text, ".") < objControl.SelStart Then
If Len(Mid(objControl.Text, InStr(objControl.Text, ".") + 1)) > (Places - 1) Then
KeyPress = 0
End If
End If
End If
End If
End Sub
