Key press

i have an example i created very similar to what you want but it uses a textbox instead of a comboxbox. also you want to change the dbcode syntax a little to make it specific to your needs. here ya go

Option Explicit
Dim cn As New ADODB.Connection
Dim Key As Long

Private Sub Form_Load()

cn.Open ("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=C:\Temp\db1.mdb")

End Sub

Private Sub Text1_Change()

'dont go at database is backspace is hit
If Key = 8 Then Exit Sub

Dim grabbedtext As String: Dim sql As String
Dim rs As New ADODB.Recordset

grabbedtext = Text1.Text
If grabbedtext = "" Then Exit Sub

sql = "Select term from temp where term like '" & grabbedtext & "%'"

Set rs = cn.Execute(sql)

If rs.EOF = False Then
    Text1.Text = rs("Term")
    Text1.SelStart = Len(grabbedtext)
    Text1.SelLength = Len(Text1.Text)
Else
End If

rs.Close
Set rs = Nothing

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
Key = KeyAscii
End Sub

oh btw - once you add the above, all you have to do is press F5 and begin typing the names in the combobox.

Thanks - Wileecoy

Here is a nice Example
Heres a simple class to do this type of thing.

Create a new class called clsBoxSearch

Add the following code to the class


Private Const LB_FINDSTRING As Long = &H18F
Private Const CB_ERR As Long = (-1)
Private Const LB_ERR As Long = (-1)
Private Const CB_FINDSTRING As Long = &H14C
Private Const CB_SHOWDROPDOWN As Long = &H14F

Private Declare Function SendMessageStr Lib _
    "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Long, _
     ByVal lParam As String) As Long
   
Public Sub FindIndexStr(ctlSource As Control, _
   ByVal str As String, intKey As Integer, _
   Optional ctlTarget As Variant, Optional ctlOutput As Variant)
Dim lngIdx As Long
Dim FindString As String

If (intKey < 32 Or intKey > 127) And _
   (Not (intKey = 13 Or intKey = 8)) Then Exit Sub

If Not intKey = 13 Or intKey = 8 Then
    If Len(ctlSource.Text) = 0 Then
        FindString = str & Chr$(intKey)
    Else
        FindString = Left$(str, ctlSource.SelStart) & Chr$(intKey)
    End If
End If

If intKey = 8 Then
   If Len(ctlSource.Text) = 0 Then Exit Sub
   Dim numChars As Integer
   numChars = ctlSource.SelStart - 1
   'FindString = Left(str, numChars)
   If numChars > 0 Then FindString = Left(str, numChars)
End If

If IsMissing(ctlTarget) And TypeName(ctlSource) = "ComboBox" Then
    Set ctlTarget = ctlSource
        If intKey = 13 Then
          Call SendMessageStr(ctlTarget.hWnd, _
             CB_SHOWDROPDOWN, True, 0&)
          Exit Sub
        End If
    lngIdx = SendMessageStr(ctlTarget.hWnd, _
       CB_FINDSTRING, -1, FindString)
ElseIf TypeName(ctlTarget) = "ListBox" Then
    ctlOutput.Clear
    If intKey = 13 Then Exit Sub
    lngIdx = SendMessageStr(ctlTarget.hWnd, _
           LB_FINDSTRING, -1, FindString)
    Dim i As Integer
    i = -1
    If lngIdx <> -1 Then
        i = lngIdx
        Do
            ctlOutput.AddItem ctlTarget.List(i)
            i = SendMessageStr(ctlTarget.hWnd, _
               LB_FINDSTRING, i, FindString)
        Loop While i > lngIdx
    End If
Else
    Exit Sub
End If
 
If lngIdx <> -1 Then
        ctlTarget.ListIndex = lngIdx
        If TypeName(ctlSource) = "TextBox" Then ctlSource.Text = ctlTarget.List(lngIdx)
        ctlSource.SelStart = Len(FindString)
        ctlSource.SelLength = Len(ctlSource.Text) - ctlSource.SelStart
End If
intKey = 0

End Sub

Now add the following to a form

A combobox called cboFonts
Two listboxes call them lstFonts and lstOutput
A text box called txtFillbox

Add the following to the genral declarations of your form

Option Explicit

Dim cBox As New clsBoxSearch

Private Sub cboFonts_KeyPress(KeyAscii As Integer)
    cBox.FindIndexStr cboFonts, cboFonts.Text, KeyAscii
End Sub

Private Sub Form_Load()
   Dim i As Integer
   Dim max As Integer
   max = Screen.FontCount
   If max > 35 Then max = 35
   For i = 1 To max
      lstFonts.AddItem Screen.Fonts(i)
      cboFonts.AddItem Screen.Fonts(i)
      Next i
End Sub

Private Sub txtFillBox_KeyPress(KeyAscii As Integer)
   cBox.FindIndexStr txtFillBox, txtFillBox.Text, _
     KeyAscii, lstFonts, lstOutput
End Sub

Hope this example helps.

Vin.

i am using simular solution :


Option Explicit

Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const CB_FINDSTRING As Long = &H14C
Private Const CB_FINDSTRINGEXACT As Long = &H158


Private Sub Combo1_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
    Case vbKeyBack
   
    Case Is >= 32
      'perform auto search
     
      If Combo1.SelLength > 0 Then
        Combo1.SelText = VBA.Chr$(KeyAscii)
      Else
        Combo1.Text = Combo1.Text & VBA.Chr$(KeyAscii)
      End If
      KeyAscii = 0
      Call TypeAheadCombo(Combo1)
  End Select
 
End Sub

Private Sub Form_Load()
  Combo1.Clear
  Combo1.AddItem "one"
  Combo1.AddItem "two"
  Combo1.AddItem "other"
  Combo1.AddItem "new"
 
End Sub

Public Sub TypeAheadCombo(ljCombo As ComboBox)
  Dim lviIndex As Integer
  Dim lvsKeyString As String
  Dim lviKeyLen As Integer
 
  lvsKeyString = ljCombo.Text
  lviKeyLen = Len(lvsKeyString)
  If lviKeyLen > 0 Then
    With ljCombo
      lviIndex = SrchComboList(.hWnd, lvsKeyString, False)
      If lviIndex <> -1 Then
        '.SetFocus
        .ListIndex = -1
        .ListIndex = lviIndex
        .SelStart = lviKeyLen
        .SelLength = Len(.Text) - lviKeyLen
      End If
    End With
  End If
End Sub

Public Function SrchComboList(hWnd As Long, _
                                  lvsFind As String, _
                                  Optional fExact As Boolean = False) As Long
  'Finds an entry in a combo box that matches the specified prefix.
  'This search is not case-sensitive.
  'Returns:
  'if found - a valid listindex
  'Else -1
  Dim lvlSearchType As Long
 
  If Len(lvsFind) = 0 Then
    SrchComboList = -1
    Exit Function
  End If
 
  Select Case fExact
    Case True
      lvlSearchType = CB_FINDSTRINGEXACT
     Case False
      lvlSearchType = CB_FINDSTRING
  End Select
  SrchComboList = SendMessageByString(hWnd, lvlSearchType, -1, lvsFind)
End Function

Similar but not the same mine wraps the code nicely in a class and can be used with comboboxes and list controls.
And gives the option to output the results to a list.

Vin.

VincentLawlor,

When I type something in, and then want to go back and change it, it won't let me backspace or replace the first chr of the combo box or the textbox.

Any ideas?

Thanks - Wileecoy.

If you use a DataCombo or DBCombo then it has this fuctionality as one of its own properties ... DBCombo1.MatchEntry = dblExtendedMatching


otherwise try my long winded workaround:

'***************************************************************************
' Created by Peter Dobson on 04/01/01 in order to provide AutoComplete
' functionality for ComboBox's with .Style set to 0, and for the ComboBox's
' to have the option to restrict Combo's data to one of the ListItem's -
' (see defect 2884)
'
' e.g. of how To use (form code):
'    Private Sub Combo1_GotFocus()
'        AutoComboGotFocus
'    End Sub
'    Private Sub Combo1_Click()
'        AutoComboClickCheck Combo1
'    End Sub
'    Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
'        KeyCode = AutoComboKeyDownCheck(Combo1, KeyCode)
'    End Sub
'    Private Sub Combo1_KeyPress(KeyAscii As Integer)
'        KeyAscii = AutoComboFind(Combo1, KeyAscii, True)
                                            'False allows non-list data
'    End Sub
'    Private Sub Combo1_Validate(Cancel As Boolean)
'       AutoComboKeyDownCheck(Combo1, vbKeyTab)
'    End Sub
'***************************************************************************

'module code
'Modification History
'====================
'Changed By      Date      Fault   Description
'==========      ====      =====   ==============
'Peter Dobson   06/06/01   5154    Fixed bug when backspace/tab is pressed
'***************************************************************************
Option Explicit

Private mnLastIndex As Integer
Private mbJustTypeSelected As Boolean

Public Property Let AutoComboDrop(ByRef cboThis As ComboBox, ByVal _
    bState As Boolean)
' Set whether combo drops down using the Down Arrow or not:
    SendMessageLong cboThis.hWnd, CB_SETEXTENDEDUI, Abs(bState), 0
End Property

Public Property Get AutoComboDrop(ByRef cboThis As ComboBox) As Boolean
' Get whether combo drops down using the Down Arrow or not:
    AutoComboDrop = (SendMessageLong(cboThis.hWnd, CB_GETEXTENDEDUI, 0, 0) <> 0)
End Property

Public Function AutoComboFind(ByRef cboCurrent As ComboBox, ByVal _
    KeyAscii As Integer, Optional ByVal LimitToList As Boolean = False)

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCB As Long, sFindString As String
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

   
    On Error GoTo Err_Handler
   
    If KeyAscii = 8 Then
        AutoComboFind = KeyAscii
        Exit Function
    ElseIf KeyAscii < 32 Or KeyAscii > 255 Then
        Exit Function
    Else
        If cboCurrent.SelLength = 0 Then
            sFindString = UCase(cboCurrent.Text & Chr$(KeyAscii))
        Else
            sFindString = Left$(cboCurrent.Text, cboCurrent.SelStart) & _
                Chr$(KeyAscii)
        End If
    End If
   
    lCB = SendMessage(cboCurrent.hWnd, CB_FINDSTRING, -1, ByVal sFindString)
    If lCB <> CB_ERR Then
        cboCurrent.ListIndex = lCB
        cboCurrent.SelStart = Len(sFindString)
        cboCurrent.SelLength = Len(cboCurrent.Text) - cboCurrent.SelStart
        AutoComboFind = 0
    Else
        If LimitToList = True And cboCurrent.ListCount > 0 Then
            AutoComboFind = 0
        Else
            AutoComboFind = KeyAscii
        End If
    End If
Err_Handler:
End Function

Public Sub AutoComboClickCheck(cboCurrent As ComboBox)
'Required because of the very strange behaviour of combo's where
'the combo's click event is fired and the current selection is lost
'when the control loses focus or its down arrow is re-clicked
    If mbJustTypeSelected = True Then
        cboCurrent.ListIndex = mnLastIndex
        mbJustTypeSelected = False
    End If
End Sub

Public Function AutoComboKeyDownCheck(cboCurrent As ComboBox, KeyCode As Integer) As Integer
'Although Tab keypress cannot be trapped without a keyboard hook the
'vbKeyTab constant can be passed form the combo's validate event
    If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
        cboCurrent.SelStart = 0
        cboCurrent.SelLength = Len(cboCurrent.Text)
        mnLastIndex = cboCurrent.ListIndex
        mbJustTypeSelected = True
        If KeyCode = vbKeyReturn Then
            SendKeys "{ESC}" 'make the list disapear but keep the focus
        End If
    Else
        AutoComboKeyDownCheck = KeyCode
    End If
End Function

Public Sub AutoComboGotFocus()
    mbJustTypeSelected = False
End Sub

wileecoy
>>When I type something in, and then want to go back and change it, it won't let me backspace or replace
the first chr of the combo box or the textbox.
Any ideas?

Just remove the checks for intKey = 8

or just add the following line to the start of the code
FindIndexStr

If intKey = 8 then exit sub

Vin.

If you have your combo box loaded, why not just set the combo box style property to dropdown list.  Then, when you push a letter, it will find the closest match.  Unless you mean it filters out the combo box to only display the selected items.

Ta-Da!

As you can see I plugged in the code and hit F5 - I didn't look through to see what the code does.

Works well.

Thanks.

wileecoy
>>When I type something in, and then want to go back and change it, it won't let me backspace or replace

Try this

add a combobox to a new form

paste the following code to the form

'Windows declarations
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
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
Private Const CB_FINDSTRING = &H14C
Private Const CB_ERR = (-1)

'Private flag
Private m_bEditFromCode As Boolean


Private Sub Form_Load()
    Dim sSysDir As String, sFile As String

    'Get files from system directory for test list
    Screen.MousePointer = vbHourglass
    sSysDir = Space$(256)
    GetSystemDirectory sSysDir, Len(sSysDir)
    sSysDir = Left$(sSysDir, InStr(sSysDir, Chr$(0)) - 1)
    If Right$(sSysDir, 1) <> "\" Then
        sSysDir = sSysDir & "\"
    End If
    sFile = Dir$(sSysDir & "*.*")
    Do While Len(sFile)
        Combo1.AddItem sFile
        sFile = Dir$
    Loop
    Screen.MousePointer = vbDefault
End Sub

'Certain keystrokes must be handled differently by the Change
'event, so set m_bEditFromCode flag if such a key is detected
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyDelete
            m_bEditFromCode = True
        Case vbKeyBack
            m_bEditFromCode = True
    End Select
End Sub

Private Sub Combo1_Change()
    Dim i As Long, j As Long
    Dim strPartial As String, strTotal As String

    'Prevent processing as a result of changes from code
    If m_bEditFromCode Then
        m_bEditFromCode = False
        Exit Sub
    End If
    With Combo1
        'Lookup list item matching text so far
        strPartial = .Text
        i = SendMessage(.hwnd, CB_FINDSTRING, -1, ByVal strPartial)
        'If match found, append unmatched characters
        If i <> CB_ERR Then
            'Get full text of matching list item
            strTotal = .List(i)
            'Compute number of unmatched characters
            j = Len(strTotal) - Len(strPartial)
            '
            If j <> 0 Then
                'Append unmatched characters to string
                m_bEditFromCode = True
                .SelText = Right$(strTotal, j)
                'Select unmatched characters
                .SelStart = Len(strPartial)
                .SelLength = j
            End If
        End If
    End With
End Sub

press F5

this is slightly modified from code I got at http://www.softcircuits.com 

work on the Change event instead...
it's better to use a Text Box with this, if your list is in a Database your SQL statment should be something like this in the change event:

SET rs = cn.execute("SELECT * FROM TableName WHERE FieldName like '%" TextBox.Text "%'")

TextBox.Text = rs("FieldName")

Regards,

RayZor

Perfect!!!!
Thanks

Thanks - you generated a lot of solutions using different controls and got some good code.

This will be a great value for someone that buys this solution in the future.

btw - nice code VincentLawlor.

Thanks

Wileecoy.

right on wileecoy.

This was a great learning experiance.

Liked your code VincentLawlor. I am a great fan of class solutions.

Glad to be of service.

No points though sniff sniff :(

Vin.