[VB6 - Aanpassen class file]

[Verwijderd]

Ik heb op't www een mooie class gevonden die een autocomplete voor een textveld regeld vanuit een listbox die de class zelf aanmaakt.
Het nadeel is dat de class geen rekening gehouden heeft met de ItemData property die, indien de waardes vanuit een database gevuld worden, de corresponderende ID's meeneemt.

Aangezien ik niet zo'n ervaring heb met classes maar wel graag die property zou willen toevoegen vraag ik jullie om tips.

De class werkt in princiepe hetzelfde als een gewone listbox dus in je form kun je gebruik maken van .addItem maar dus niet van .ItemData.

Zouden jullie mij op weg kunnen helpen dit voor elkaar te krijgen?

Bedankt voor jullie medewerking, de code staat hieronder

code:

Option Explicit

'Beware, the length of strings used is determined by the following const. For use of longer
    'words or sentences increase the const first
Private Const StringL As Long = 20
Private Const MaxItemsInDropdown As Long = 10
Private Const DropdownViewTime = 3 'seconds the dropdown stays visible. Set to 0 to keep visible

Private WithEvents TB As TextBox
Private WithEvents DropDown As ListBox
Private DropDownCreated As Boolean, TimerStart!, LineHeight%, blnCancelTimer As Boolean
Private NumberOfItems As Long, sItems As String, LastFill As String, UseDropDown As Boolean

Public OnlyAllowList As Boolean

Property Let UseDropDownList(B As Boolean)
    UseDropDown = B
    If B Then
        CreateDropDown
    ElseIf DropDownCreated Then
        RemoveDropDown
    End If
End Property
Property Get UseDropDownList() As Boolean
    UseDropDownList = UseDropDown
End Property

Property Set AutoCompleteTextbox(T As TextBox)
    If DropDownCreated And Not TB Is Nothing Then
        If Not TB.Parent Is T.Parent Then RemoveDropDown
    End If
    Set TB = T
    LastFill = ""
    TB_GotFocus
    CreateDropDown
End Property

Sub AddItems(ParamArray Items())
    Dim varX
    For Each varX In Items
        AddItem CStr(varX)
    Next
End Sub

Private Sub RemoveDropDown()
    If Not DropDownCreated Then Exit Sub
    Dim sName As String
    sName = DropDown.Name
    DropDown.Clear
    Set DropDown = Nothing
    TB.Parent.Controls.Remove sName
    DropDownCreated = False
    blnCancelTimer = True
End Sub
Private Sub CreateDropDown()
    If Not UseDropDown Then Exit Sub
    If Not DropDownCreated Then Set DropDown = TB.Parent.Controls.Add("vb.listbox", "lstDropDownAutoC1")
    If Not TB Is Nothing Then
        With DropDown
            .Move TB.Left, TB.Top + TB.Height, TB.Width, 1000
            .ZOrder
            .TabStop = False
            .BackColor = TB.BackColor
            Dim F As Font
            Set F = .Parent.Font
            Set .Parent.Font = TB.Font
            Set .Font = TB.Font
            LineHeight = .Parent.TextHeight("atpPjkKyX") + 30
            Set .Parent.Font = F
        End With
    End If
    DropDownCreated = True
End Sub
Private Sub HideDropDown()
    If DropDownCreated Then DropDown.Visible = False
End Sub

Private Property Get Item(ByVal Index As Long) As String
    Item = Mid$(sItems, Index * StringL + 1, StringL)
End Property

Public Sub AddItem(sInput As String)
    If Len(sInput) = 0 Then Exit Sub
    Dim S As String * StringL
    S = sInput
    Dim I&
    For I = 0 To NumberOfItems - 1
        If Item(I) > S Then Exit For
    Next
    If I = NumberOfItems Then
        sItems = sItems & S
    Else
        I = I * StringL
        sItems = Left$(sItems, I) & S & Mid$(sItems, I + 1)
    End If
    NumberOfItems = NumberOfItems + 1
End Sub

Property Get GetList() As String()
    Dim Arr() As String, I&
    ReDim Arr(NumberOfItems - 1)
    For I = 0 To NumberOfItems - 1
        Arr(I) = RTrim$(Item(I))
    Next
    GetList = Arr
End Property

Sub ShowList(Optional AdditionalMessage As String = "List contains the following words")
    Dim I&, S$
    For I = 0 To NumberOfItems - 1
        S = S & vbCrLf & Item(I)
    Next
    MsgBox AdditionalMessage & vbCrLf & S, vbInformation
End Sub

Private Sub Class_Initialize()
    'default values
    UseDropDown = True
End Sub

Private Sub Class_Terminate()
    Set TB = Nothing
    blnCancelTimer = True
End Sub
Private Property Get DropDownVisible() As Boolean
    If DropDownCreated Then
        DropDownVisible = DropDown.Visible
    End If
End Property
Private Sub DropDownChosen()
    TB.SetFocus
    HideDropDown
    TB.SelStart = 0
    TB.SelLength = Len(TB.Text)
End Sub

Private Sub DropDown_Click()
    TB.Text = DropDown.Text
End Sub
Private Sub DropDown_DblClick()
    DropDownChosen
End Sub
Private Sub DropDown_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then DropDownChosen
End Sub

Private Sub TB_GotFocus()
    TB.SelStart = 0
    TB.SelLength = Len(TB.Text)
End Sub

Private Sub TB_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 40 And DropDownVisible Then
        DropDown.SetFocus
        DropDown.ListIndex = 0
    End If
End Sub

Private Sub TB_KeyPress(keyascii As Integer)
    If keyascii < 32 Then
        LastFill = ""
        HideDropDown
        Exit Sub
    End If
    Dim P As Long, C As String * 1
    C = Chr$(keyascii)
    P = TB.SelStart + 1
    If Len(LastFill) Then
        If StrComp(Mid$(LastFill, P, 1), C, vbTextCompare) = 0 Then
            TB.SelStart = P
            TB.SelLength = Len(TB.Text)
            keyascii = 0
            If DropDownVisible Then
                'check the items in the dropdown, if they still qualify. The first one always qualifies
                Dim T As String
                T = Left$(TB.Text, TB.SelStart)
                With DropDown
                    For P = .ListCount - 1 To 1 Step -1
                        If InStr(1, .List(P), T, vbTextCompare) <> 1 Then .RemoveItem P
                    Next
                    .Visible = .ListCount > 1
                    If .Visible Then SetHeightDropDown
                End With
            End If
            Exit Sub
        End If
    End If
    If FindItem(Left$(TB.Text, P - 1) & C) Then
        keyascii = 0
    ElseIf OnlyAllowList Then
        Beep
        keyascii = 0
    Else
        LastFill = ""
    End If

End Sub
Private Function FindItem(strText As String) As Boolean
    If Len(strText) = 0 Then Exit Function
    Dim P As Long, Start As Long, L As Long
    Do
        P = InStr(P + 1, sItems, strText, vbTextCompare)
        If P = 0 Then Exit Do
        If (P - 1) Mod StringL = 0 Then
            If Start = 0 Then
                Start = P \ StringL
                LastFill = RTrim$(Item(Start))
                L = Len(strText)
                TB.Text = strText & Mid$(LastFill, L + 1)
                TB.SelStart = L
                TB.SelLength = Len(TB.Text)
                FindItem = True
                If Not UseDropDown Then Exit Function '<- !exit point!
            Else
                L = P
            End If
        End If
    Loop
    If UseDropDown Then
        With DropDown
            .Clear
            L = L \ StringL
            .Visible = Start > 0 And (L > Start)
            If .Visible Then
                For P = Start To L
                    .AddItem RTrim$(Item(P))
                Next
                SetHeightDropDown
            End If
        End With
    End If
End Function

Private Sub SetHeightDropDown()
    Dim I&
    With DropDown
        I = .ListCount
        If I > MaxItemsInDropdown Then I = MaxItemsInDropdown
        I = LineHeight * I
        .Height = I
        'make sure the listbox is within the forms range
        I = .Parent.ScaleHeight - .Top - .Height
        If I < 0 Then .Height = .Height + I
    End With
    StartTimer
End Sub
Private Sub StartTimer()
    If DropdownViewTime = 0 Then Exit Sub
    TimerStart = Timer '(re)set timer
    Static InTimer As Boolean
    If InTimer Then Exit Sub 'if already in the loop, exit sub. timer can be reset to stay in loop longer
    InTimer = True
    blnCancelTimer = False
    Do While Timer - TimerStart < DropdownViewTime And Not blnCancelTimer
        DoEvents
    Loop
    On Error Resume Next ' necessary to prevent errors on unloading!
    If Not DropDown Is Nothing Then
        If Not DropDown.Parent.ActiveControl Is DropDown Then HideDropDown
    End If
    InTimer = False
End Sub

Private Sub TB_LostFocus()
    If Not TB.Parent.ActiveControl Is DropDown Then HideDropDown
End Sub

Private Sub TB_Validate(Cancel As Boolean)
    If Len(LastFill) Then
        'extra to be sure capitals are the same
        TB.Text = LastFill
    ElseIf OnlyAllowList And Len(TB.Text) > 0 Then
        Cancel = Not FindItem(TB.Text)
        If Cancel Then MsgBox "Item not in list!", vbExclamation
    End If
    If DropDownVisible Then DropDown.Clear
End Sub

[gorgi_19]

Zouden jullie mij op weg kunnen helpen dit voor elkaar te krijgen?

Zoals het er nu uitziet, lijkt het me te veel op "Wie kan dit voor mij oplossen". 277 regels code zijn niet nodig; je hebt het niet zelf geschreven bovendien. Verder geef je zelf al aan dat je niet zo thuis bent in het gebruik van Classes.

Meest makkelijke optie lijkt me om de maker te mailen. Sowieso kan het geen kwaad om je anders eerst eens rustig in te gaan lezen wat classes zijn en doen en wat je er mee kan, om pas daarna iets complexere zaken als dit aan te gaan pakken.

Deze gaat in deze vorm iig dicht.

[ Voor 6% gewijzigd door gorgi_19 op 11-05-2004 12:35 ]