Search Tools Links Login

Combobox Autofill / Quicken style combobox


This class module automatically fills the text of a combo box, using an API call to look up the text from its list.

Original Author: unknown

Inputs

Dim goAutoFill as New clsComboFill
' In the Change event of the combo box:
Call go_AutoFill.GetListValue(cboBoxName)
' In the KeyUp event of the combo box:
Call go_AutoFill.SupressKeyStroke(cboBox, KeyCode)

Assumptions

Copy this code into a class module called 'clsComboFill.'

Returns

Only returns the contents of the combobox's list, or ignores the rest.

API Declarations

' In the class module:
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_FINDSTRINGEXACT = &H158
Private Const CB_FINDSTRING = &H14C
Private Const CB_ERR = (-1)

Code

Option Explicit
' Created by mkeller@hotmail.com - 9/12/2000
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_FINDSTRINGEXACT = &H158
Private Const CB_FINDSTRING = &H14C
Private Const CB_ERR = (-1)
' Used to hold the keycode supressions
Private m_bSupressKeyCode As Boolean
Private Property Let SupressKeyCode(bValue As Boolean)
  m_bSupressKeyCode = bValue
End Property
Private Property Get SupressKeyCode() As Boolean
  SupressKeyCode = m_bSupressKeyCode
End Property
Public Sub SupressKeyStroke(cboBoxName As ComboBox, KeyCode As Integer)
' This method is called from the KeyDown
' event of a ComboBox.
  ' Let's just assume we only want to supress
  ' backspace and the delete keys.
  If cboBoxName.Text <> "" Then
    Select Case KeyCode
      Case vbKeyDelete
        SupressKeyCode = True
      Case vbKeyBack
        SupressKeyCode = True
    End Select
  End If
End Sub
Public Sub GetListValue(cboBoxName As ComboBox)
' Call this method in the 'Change' event a
' ComboBox.
  Dim lSendMsgContainer As Long, lUnmatchedChars As Long
  Dim sPartialText As String, sTotalText As String
  ' Prevent processing as a result of changes from code
  If m_bSupressKeyCode Then
    m_bSupressKeyCode = False
    Exit Sub
  End If
  With cboBoxName
    ' Lookup list item matching text so far
    sPartialText = .Text
    lSendMsgContainer = SendMessage(.hWnd, CB_FINDSTRING, -1, ByVal sPartialText)
    ' If match found, append unmatched characters
    If lSendMsgContainer <> CB_ERR Then
      ' Get full text of matching list item
      sTotalText = .List(lSendMsgContainer)
      ' Compute number of unmatched characters
      lUnmatchedChars = Len(sTotalText) - Len(sPartialText)
      If lUnmatchedChars <> 0 Then
        ' Append unmatched characters to string
        SupressKeyCode = True
        .SelText = Right(sTotalText, lUnmatchedChars)
        ' Select unmatched characters
        .SelStart = Len(sPartialText)
        .SelLength = lUnmatchedChars
      End If
    End If
  End With
End Sub
Private Sub Class_Terminate()
' If there's any kind of err, let's just flush it
' and go about our business. Whoomp, there it
' is!
  Err.Clear
End Sub

About this post

Posted: 2002-06-01
By: ArchiveBot
Viewed: 80 times

Categories

Visual Basic 6

Attachments

No attachments for this post


Loading Comments ...

Comments

No comments have been added for this post.

You must be logged in to make a comment.