AUTOCOMPLETA.OCX

Option Explicit
Option Compare Text

' Name: AutoComplete
' (C) 2000 by FreeVBCode.com
' http://www.freevbcode.com

' Version 1.01 Changes added by: Amit Garg
' Email: sutradhaar@bigfoot.com
' Date: 4 April, 2000

Private Const ERR_INVALID_LIST = 20000
Private Const ERR_INVALID_ELEMENT = 20000

Private Const ERR_INVALID_LIST_MSG = "Expected: Array or Collection"
Private Const ERR_INVALID_ELEMENT_MSG = "An invalid element is present in the list"

Private Const LB_GETITEMHEIGHT = &H1A1
Private Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private psItemArray() As String
Private plItemDataArray() As Long
Private plInterval As Long
Private piLastKey As Integer
Private psngLastHeight As Single
Private piLastSelected As Integer

'EVENTS
Public Event Change()
Public Event Click()
Public Event DblClick()

Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event Scroll()
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

[c]Private Sub lstItems_Click()
    piLastSelected = lstItems.ListIndex
    txtAutoComplete.Text = lstItems.Text
    lstItems.Visible = False
    lstItems.Clear
    
    UserControl.Height = txtAutoComplete.Height
    
    RaiseEvent Click
End Sub

Private Sub lstItems_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub lstItems_GotFocus()
    lstItems.Visible = lstItems.ListCount > 0
    UserControl_Resize
End Sub

Private Sub lstItems_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'HighlightLBItem lstItems.hwnd, X, Y
End Sub

Private Sub txtAutoComplete_Change()
    RaiseEvent Change
End Sub

Private Sub lstItems_Scroll()
    RaiseEvent Scroll
End Sub

Private Sub Timer1_Timer()
    Dim sTemp As String
    Dim lLen As Long
    Dim iCtr As Integer
    Dim iCount As Integer
    Dim b1 As Boolean
    Dim b2 As Boolean
    Dim index As Integer
    Dim bNoRemove As Boolean
    
    Static oldsTemp As String
    
    With lstItems
    iCount = .ListCount
    If .ListCount = 0 Then bNoRemove = True
  
    sTemp = txtAutoComplete.Text
    lLen = Len(sTemp)
    
    'If lstItems.ListCount > 0 Then lstItems.Clear
    index = 0
    
    If lLen >= 0 Then
    
    For iCtr = 0 To UBound(psItemArray)
      If psItemArray(iCtr) <> "" Then
        b1 = psItemArray(iCtr) Like sTemp & "*" 'if item in array should be displayed
        b2 = psItemArray(iCtr) Like oldsTemp & "*" 'if last item should not be displayed
        If oldsTemp = "" Then b2 = False
        If sTemp = "" Then
            b1 = False
            b2 = True
        End If
        
        If (b1 And b2) Then
            If Not InList(psItemArray(iCtr)) Then lstItems.AddItem psItemArray(iCtr), index
            index = index + 1
        ElseIf (b1 And Not b2) Then
            If index > .ListCount Then
                lstItems.AddItem psItemArray(iCtr), .ListCount
                lstItems.ItemData(.ListCount - 1) = plItemDataArray(iCtr)
            Else
                lstItems.AddItem psItemArray(iCtr), index
                lstItems.ItemData(index) = plItemDataArray(iCtr)
            End If
            index = index + 1
        ElseIf (Not b1 And b2 And lstItems.ListCount > 0 And Not bNoRemove) Then
            If index > .ListCount - 1 Then index = .ListCount - 1
            lstItems.RemoveItem index
           
        End If
       
      End If
    Next
    
    End If
    
    oldsTemp = sTemp
    
    If .ListCount > 0 Then
    
        If Not .Visible Then
            .Visible = True
             UserControl_Resize
        End If
    Else
       .Visible = False
        UserControl.Height = psngLastHeight
              
    End If
    On Error Resume Next
    
    End With
    If iCount <> lstItems.ListCount Then UserControl_Resize
    Timer1.Enabled = False
End Sub

Private Sub txtAutoComplete_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub txtAutoComplete_KeyDown(KeyCode As Integer, Shift As Integer)
    Timer1.Enabled = False
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub txtAutoComplete_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub txtAutoComplete_KeyUp(KeyCode As Integer, Shift As Integer)
    piLastKey = KeyCode
    If KeyCode <> 13 Then
        Timer1.Enabled = True
    
    Else
        lstItems.Visible = False
        UserControl.Height = txtAutoComplete.Height
        
    End If
        RaiseEvent KeyUp(KeyCode, Shift)

    If KeyCode = 38 Then lstItems.SetFocus
End Sub

Private Sub txtAutoComplete_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub txtAutoComplete_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub txtAutoComplete_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_ExitFocus()
    lstItems.Visible = False
    UserControl.Height = txtAutoComplete.Height

End Sub

Private Sub UserControl_Initialize()

    lstItems.Visible = False
    
    ReDim psItemArray(0) As String
    ReDim plItemDataArray(0) As Long
    
    txtAutoComplete.ZOrder 0
    lstItems.ZOrder 0

End Sub

Public Sub AddItem(Item As String)
    If Item = "" Then Exit Sub
    
    If psItemArray(0) = "" Then
        psItemArray(0) = Item
    Else
        ReDim Preserve psItemArray(UBound(psItemArray) + 1) As String
        psItemArray(UBound(psItemArray)) = Item
        ReDim Preserve plItemDataArray(UBound(psItemArray)) As Long
        
    End If

End Sub

Public Sub AddArrayOrCollection(ByVal List As Variant)
'populates the master list
'with elements of an array or a collection

    Dim bArray As Boolean
    Dim sTemp As String, iTemp As Integer
    Dim iCtr As Integer
    Dim lStartPoint As Integer, lEndPoint As Long
    
    If IsArray(List) Then
        bArray = True
    ElseIf Not (TypeOf List Is Collection) Then
        Err.Raise ERR_INVALID_LIST, ERR_INVALID_LIST_MSG
        Exit Sub
    End If
    
    
     'confirm that each value
        'in the list can be added
        'to a list control
     
    If ValidateValues(List) = False Then
        Err.Raise ERR_INVALID_ELEMENT, , ERR_INVALID_ELEMENT_MSG
        Exit Sub
    End If
    
    
    
    If bArray Then
        lStartPoint = LBound(List)
        lEndPoint = UBound(List)
        ReDim vValues(lStartPoint To lEndPoint)
        
     
            For iCtr = lStartPoint To lEndPoint
                AddItem CStr(List(iCtr))
            Next
        
        
        
    Else 'if not barray
            For iCtr = 1 To List.Count
                AddItem CStr(List.Item(iCtr))
            
            Next
    End If

End Sub

Private Function ValidateValues(Values As Variant) As Boolean

'Purpose: Determines if all the values of a collection, variant array
'has a value that can be converted into a string

Dim bCollection As Boolean
Dim iBadVarTypes(4) As Integer
Dim v As Variant
Dim i As Integer
Dim lCtr As Long, lListCount As Long
Dim lStartPoint As Long
Dim iCount As Integer

Dim bAns As Boolean

'assumes vbEmpty and vbNull will
'be converted to ""
iBadVarTypes(0) = vbError
iBadVarTypes(1) = vbDataObject
iBadVarTypes(2) = vbUserDefinedType
iBadVarTypes(3) = vbArray
iBadVarTypes(4) = vbObject

bAns = True
iCount = UBound(iBadVarTypes)

If IsObject(Values) Then
    If Not TypeOf Values Is Collection Then
        ValidateValues = False
        Exit Function
    End If
Else
    If Not IsArray(Values) Then 'single value
    
        For i = 0 To iCount
            If VarType(Values) = iBadVarTypes(i) Then
                bAns = False
                Exit For
            End If
        Next
        
        ValidateValues = bAns
        Exit Function
  End If
End If

bCollection = IsObject(Values) 'has to be collection

If bCollection Then
    For Each v In Values
        For i = 0 To iCount
            If VarType(v) = iBadVarTypes(i) Or VarType(v) = iBadVarTypes(i) + vbVariant Or IsObject(v) Then
                bAns = False
                Exit For
            End If
        Next
     If bAns = False Then Exit For
    Next
Else
    lListCount = UBound(Values)
    lStartPoint = LBound(Values)
    
    For lCtr = lStartPoint To lListCount
   
       
        For i = 0 To iCount
            If VarType(Values(lCtr)) = iBadVarTypes(i) Or IsArray(Values(lCtr)) Or IsObject(Values(lCtr)) Then
                bAns = False
                Exit For
            End If
        Next
    If bAns = False Then Exit For
    Next
End If

ValidateValues = bAns

End Function

Public Sub AddItems(ParamArray Items() As Variant)
Dim iCtr As Integer
Dim stest As String
Dim lNewElement As Long

'On Error Resume Next
'ALL OR NONE.  If instead you want to add all valid element and disregard
'invalid ones, change to only one for loop
For iCtr = 0 To UBound(Items)
    stest = CStr(Items(iCtr))
    If Err.Number > 0 Then
        Err.Raise ERR_INVALID_ELEMENT, , ERR_INVALID_ELEMENT_MSG
        Exit Sub
   End If
Next

For iCtr = 0 To UBound(Items)
    AddItem CStr(Items(iCtr))
Next

End Sub

Private Sub UserControl_InitProperties()

Text = Ambient.DisplayName

'these were vb's defaults for
'a text box in my tests
UserControl.Width = 1215
UserControl.Height = 495

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

With PropBag

BackColor = .ReadProperty("BackColor", lstItems.BackColor)
Enabled = .ReadProperty("Enabled", True)
FontBold = .ReadProperty("FontBold", False)
FontItalic = .ReadProperty("FontItalic", False)
FontName = .ReadProperty("FontName", "Ms Sans Serif")
FontSize = .ReadProperty("FontSize", 8)
FontStrikethru = .ReadProperty("FontStrikethru", False)
FontUnderline = .ReadProperty("FontUnderline", False)
ForeColor = .ReadProperty("ForeColor", lstItems.ForeColor)
Interval = .ReadProperty("Interval", 1)
MaxLength = .ReadProperty("MaxLength", 0)
Text = .ReadProperty("Text", "")

End With
End Sub

Private Sub UserControl_Resize()
On Error Resume Next

txtAutoComplete.Top = 0
txtAutoComplete.Left = 0
  lstItems.Left = 0

With UserControl
    txtAutoComplete.Width = .Width
    lstItems.Width = .Width
   lstItems.Top = txtAutoComplete.Height
    
   If psngLastHeight = 0 Then psngLastHeight = UserControl.Height

If lstItems.Visible Then

        'lstItems.Height = AutoSizeLBHeight(lstItems)
        AutoSizeLBHeight lstItems
        .Height = lstItems.Height + txtAutoComplete.Height
Else
        lstItems.Height = 0
        'If UserControl.Ambient.UserMode = False Then
            txtAutoComplete.Height = .Height
        'Else
            
            'txtAutoComplete.Height = UserControl.Height
            
            'txtAutoComplete.Height = psngLastHeight
            
        'End If
End If

End With
End Sub

Public Sub Clear()
    ReDim psItemArray(0) As String
    ReDim plItemDataArray(0) As Long
    lstItems.Clear
End Sub

Public Sub RemoveItem(index As Integer)
If index > UBound(psItemArray) Then
    Err.Raise 381
Else
    ArrayRemoveItem psItemArray, index
    ArrayRemoveItem plItemDataArray, index
End If
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag

.WriteProperty "BackColor", BackColor
.WriteProperty "Enabled", Enabled, True
.WriteProperty "FontBold", FontBold, False
.WriteProperty "FontItalic", FontItalic
.WriteProperty "FontName", FontName, "Ms Sans Serif"
.WriteProperty "FontSize", FontSize, 8
.WriteProperty "FontStrikethru", FontStrikethru, False
.WriteProperty "FontUnderline", FontUnderline, False
.WriteProperty "ForeColor", ForeColor
.WriteProperty "Interval", Interval, 1
.WriteProperty "MaxLength", MaxLength, 0
.WriteProperty "Text", Text

End With

End Sub

Private Function AutoSizeLBHeight(LB As Object) As Boolean

If Not TypeOf LB Is ListBox Then Exit Function

On Error GoTo ErrHandler

Dim lItemHeight As Long
Dim lRet As Long
Dim lItems As Long
Dim sngTwips As Single
Dim sngLBHeight As Single

If LB.ListCount = 0 Then
    LB.Height = 125
    AutoSizeLBHeight = True
    
Else
    lItems = LB.ListCount
    '7 seems to be how many IE 5 displays, so why not me
    If lItems > 7 Then lItems = 7
    lItemHeight = SendMessage(LB.hwnd, LB_GETITEMHEIGHT, 0&, 0&)
    If lItemHeight > 0 Then
        sngTwips = lItemHeight * Screen.TwipsPerPixelY
        sngLBHeight = (sngTwips * lItems) + 125
        LB.Height = sngLBHeight
        AutoSizeLBHeight = True
    End If
End If

ErrHandler:
End Function

Private Sub ArrayRemoveItem(ItemArray As Variant, ByVal ItemElement As Long)
    Dim lCtr As Long
    Dim lTop As Long
    Dim lBottom As Long
    
    If Not IsArray(ItemArray) Then
        Err.Raise 13, , "Type Mismatch"
        Exit Sub
    End If
    
    lTop = UBound(ItemArray)
    lBottom = LBound(ItemArray)
    
    For lCtr = ItemElement To lTop - 1
        ItemArray(lCtr) = ItemArray(lCtr + 1)
    Next
    
    ReDim Preserve ItemArray(lBottom To lTop - 1)

End Sub

Private Sub HighlightLBItem(ByVal LBHwnd As Long, ByVal X As Single, ByVal Y As Single)
    Dim ItemIndex As Long
    Dim AtThisPoint As POINTAPI
    AtThisPoint.X = X \ Screen.TwipsPerPixelX
    AtThisPoint.Y = Y \ Screen.TwipsPerPixelY
    Call ClientToScreen(LBHwnd, AtThisPoint)
    ItemIndex = LBItemFromPt(LBHwnd, AtThisPoint.X, AtThisPoint.Y, False)
    If ItemIndex <> SendMessage(LBHwnd, LB_GETCURSEL, 0, 0) Then
        Call SendMessage(LBHwnd, LB_SETCURSEL, ItemIndex, 0)
    End If
End Sub

Private Function InList(ByVal Item As String) As Boolean
Dim lCtr As Long
For lCtr = 0 To lstItems.ListCount - 1
If lstItems.List(lCtr) = Item Then
    InList = True
    Exit Function
End If
Next

End Function