by Cyrus Lacaba (3 Submissions)
Category: OLE/COM/DCOM/Active-X
Compatability: VB.NET
Difficulty: Unknown Difficulty
Originally Published: Tue 18th July 2006
Date Added: Mon 8th February 2021
Rating: (1 Votes)
Updated Version of Auto Select Combo Box
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'
'Email: [email protected]
' [email protected]
Option Explicit
Private m_DecimalEntry As Boolean
Private m_collection() As String
Private a As New Collection
Private b As New Collection
Private c As New Collection
Private m_lngpopulated&
Private strconcat$
'-----------------------
Public Event Click()
Public Event DblClick()
Public Property Get Text() As String
Text = Combo1.Text
End Property
Public Property Let Text(ByVal NewValue As String)
Combo1.Text = NewValue
End Property
Public Property Get Enabled() As Boolean
Enabled = Combo1.Enabled
End Property
Public Property Let Enabled(ByVal NewValue As Boolean)
Combo1.Enabled = NewValue
End Property
Public Property Get Locked() As Boolean
Locked = Combo1.Locked
End Property
Public Property Let Locked(ByVal NewValue As Boolean)
Combo1.Locked = 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
c.Add 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&
Dim strItem$, strItemID$
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) & ":" & c.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)
Combo1.ItemData(Combo1.NewIndex) = c.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
strItem$ = Trim(Mid(b.Item(p), 1, InStr(1, b.Item(p), ":") - 1))
strItemID$ = Trim(Mid(b.Item(p), Len(strItem$) + 2))
Combo1.AddItem strItem$
Combo1.ItemData(Combo1.NewIndex) = strItemID$
md& = 1
Next
If Combo1.ListCount <> 0 Then
'Check This Out
Combo1.Text = Combo1.List(0)
Combo1.ListIndex = 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 + 1
c.Remove Index + 1
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