'NOTE: Make sure Listbox is sorted
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Const LB_FINDSTRING = &H18F
Dim ListBoxItems() As String
Const Letters As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim LetterPos(1 To 26) As Long
Dim PrevTextLen As Long
Private Sub Form_Load()
Dim Itm As Long
Dim CurrentLetter As String
Dim PrevLetter As String
'Add Items
List1.AddItem "Peaches"
List1.AddItem "Nectarines"
List1.AddItem "Pears"
List1.AddItem "Quinces"
List1.AddItem "Cherries"
List1.AddItem "Apricots"
List1.AddItem "Apples"
List1.AddItem "Plums"
List1.AddItem "Figs"
List1.AddItem "Kiwis"
List1.AddItem "Olives"
List1.AddItem "Clementine"
List1.AddItem "Kumquat"
List1.AddItem "Minneola"
List1.AddItem "Mandarin"
List1.AddItem "Orange"
List1.AddItem "Satsuma"
List1.AddItem "Tangarine"
List1.AddItem "Tangelo"
List1.AddItem "Lemon"
List1.AddItem "Rough Lemon"
List1.AddItem "Lime"
List1.AddItem "Leech Lime"
List1.AddItem "Grapefruit"
List1.AddItem "Pummelo"
List1.AddItem "Sweety"
List1.AddItem "Ugli"
'We now add them all to an array. Since we sorted first, it makes it easier
ReDim ListBoxItems(1 To List1.ListCount) As String
For Itm = 1 To List1.ListCount
CurrentLetter = Left(List1.List(Itm), 1)
If CurrentLetter <> PrevLetter And Len(CurrentLetter) > 0 Then
LetterPos(InStr(1, Letters, CurrentLetter, vbTextCompare)) = Itm
PrevLetter = CurrentLetter
End If
ListBoxItems(Itm) = List1.List(Itm - 1)
Next
End Sub
Private Sub Text1_Change()
Dim FirstLetter As String
Dim UpperRange As Integer
Dim LowerRange As Integer
Dim Itm As Integer
Dim x As Long
Dim RemItem As Long
Dim r As Long
LockWindowUpdate List1.hwnd
If Len(Text1) = 0 Then 'There is nothing in the textbox so we have to write all items again
List1.Clear
For Itm = 1 To UBound(ListBoxItems)
List1.AddItem ListBoxItems(Itm)
Next
ElseIf Len(Text1) < PrevTextLen Then
'We deleted something
List1.Clear
FirstLetter = Left(Text1, 1)
'Get Range
LowerRange = LetterPos(InStr(1, Letters, FirstLetter, vbTextCompare))
For x = InStr(1, Letters, FirstLetter, vbTextCompare) + 1 To 26 Step 1
If Not LetterPos(x) = 0 Then
UpperRange = LetterPos(x)
Exit For
End If
Next
If LowerRange < 1 Or UpperRange < 1 Then
PrevTextLen = Len(Text1)
LockWindowUpdate 0
Exit Sub
End If
For r = LowerRange To UpperRange
If InStr(1, ListBoxItems(r), Text1, vbTextCompare) = 1 Then
List1.AddItem ListBoxItems(r)
End If
Next
ElseIf Len(Text1) = 1 Then
'First Letter, so we remove all unwanted items before and after it
'Should be a bit faster than having to check each item has the text or not
FirstLetter = Left(Text1, 1)
If LetterPos(InStr(1, Letters, FirstLetter, vbTextCompare)) < 1 Then
List1.Clear
PrevTextLen = Len(Text1)
LockWindowUpdate 0
Exit Sub
End If
'Get Range
LowerRange = LetterPos(InStr(1, Letters, FirstLetter, vbTextCompare))
If LowerRange = 1 Then LowerRange = 0
For x = InStr(1, Letters, FirstLetter, vbTextCompare) + 1 To 26 Step 1
If Not LetterPos(x) = 0 Then
UpperRange = LetterPos(x)
Exit For
End If
Next
If UpperRange = 0 Then UpperRange = List1.ListCount
'Remove all those after it
For RemItem = UpperRange To List1.ListCount - 1 Step 1
List1.RemoveItem UpperRange
Next
'Remove all those before it
For RemItem = 1 To LowerRange Step 1
List1.RemoveItem 0
Next
ElseIf Len(Text1) > 1 Then
'Remove items using a loop now. Anything that doesn't match
For r = List1.ListCount - 1 To 0 Step -1
'When we look at the item string,
'we must make sure that the text we wrote starts at pos 1
If InStr(1, List1.List(r), Text1, vbTextCompare) <> 1 Then
List1.RemoveItem r
End If
Next
End If
PrevTextLen = Len(Text1)
LockWindowUpdate 0
'Retrieve the item's listindex
List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text))
End Sub