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
Loading Comments ...
Comments
No comments have been added for this post.
You must be logged in to make a comment.