Jeder kennt es vom Handy oder aus der VB-IDE, man gibt einen buchstaben ein und schon erscheint eine ganze Latte von Wörtern die mit dem jeweiligen Buchstaben anfangen, in VB sind es natürlich nicht nur Wörter . In diesem Tipp wird gezeigt wie man soetwas unter VB realisiert. Alles was dazu braucht, ist eine Textbox, sowie eine Listbox, die man auf der Form plaziert. Sobald in der Textbox ein a eingegeben wird, erscheint eine Liste mit Wörtern die mit a beginnen. Dies kann natürlich mit jedem Buchstaben, oder auf eine rtf-box erweitert werden. Here's the code: ' benötigte API-Deklarationen Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As String) As Long Private Declare Function GetCaretPos Lib "user32" ( _ lpPoint As POINTAPI) As Long Private Declare Function DrawText Lib "user32" _ Alias "DrawTextA" ( _ ByVal hdc As Long, _ ByVal lpStr As String, _ ByVal nCount As Long, _ lpRect As RECT, _ ByVal wFormat As Long) As Long Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Const DT_CALCRECT = &H400 Const LB_FINDSTRING = &H18F Const SP = 3& ' ListBox füllen Private Sub Form_Load() Dim aa As String List1.AddItem "Aaron" List1.AddItem "Abend" List1.AddItem "Abendhimmel" List1.AddItem "Abacus" List1.AddItem "Auto" List1.AddItem "jürgen" Text1.Text = "Geben Sie in diese TextBox Wörter ein, " & _ "die mit dem Buchstaben A beginnen" Text1.SelStart = 0 Text1.SelLength = Len(Text1.Text) End Sub ' Doppelklick auf Auto-Liste Private Sub List1_DblClick() Text1_KeyPress 32 End Sub ' Wenn Auto-Liste Fokus erhält, sofort Fokus ' wieder in die TextBox setzen Private Sub List1_GotFocus() Text1.SetFocus End Sub ' Auto-Liste anzeigen Private Sub Text1_Change() Dim p As POINTAPI Dim hDcT As Long Dim R As RECT Dim x As Long Dim y As Long Dim Word As String Dim x1 As Long Dim x2 As Long Dim aa As String Dim Lx As Long Dim Ly As Long hDcT = Text1.Parent.hdc Call DrawText(hDcT, CStr("x"), -1, R, DT_CALCRECT) Call GetCaretPos(p) ' ListBox-Position bestimmen Lx = Text1.Left + (p.x + SP) * Screen.TwipsPerPixelX If Lx + List1.Width > Text1.Width Then Lx = Text1.Width - List1.Width End If Ly = Text1.Top + (p.y + R.Bottom + SP) * Screen.TwipsPerPixelY If Ly + List1.Height > Text1.Height Then Ly = Text1.Top + p.y * Screen.TwipsPerPixelY - List1.Height End If ' ListBox positionieren List1.Left = Lx List1.Top = Ly ' aktuelles Wort ermitteln Word = FindWordPos(Text1, x1, x2) If Word <> "" Then If LCase(Left$(Word, 1)) = "a" Then List1.Visible = True Else List1.Visible = False End If Else List1.Visible = False End If ' Eintrag in der ListBox markieren (falls gefunden) x = SendMessage(List1.hwnd, LB_FINDSTRING, -1, Word) If x <> -1 Then List1.TopIndex = x List1.ListIndex = x End Sub ' Auto-Liste ausblenden Private Sub Text1_Click() List1.Visible = False End Sub Private Sub Text1_KeyDown(KeyCode As Integer, _ Shift As Integer) Dim x As Long ' Falls Auto-Liste angezeigt wird, soll mit den ' Pfeil Hoch/Runter-Tasten innerhalb der ListBox ' gescrollt werden With List1 If (.Visible) And _ (KeyCode = vbKeyDown Or KeyCode = vbKeyUp) Then x = .ListIndex If x = -1 Then .ListIndex = .TopIndex Else If KeyCode = vbKeyDown Then If x + 1 < .ListCount Then .ListIndex = x + 1 ElseIf KeyCode = vbKeyUp Then If x - 1 > -1 Then .ListIndex = x - 1 End If KeyCode = 0 End If End If End With End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) ' Prüfen, ob aktuelles Wort in Auto-Liste vorhanden Dim x As Long Dim x1 As Long Dim x2 As Long Dim aa As String Dim Word As String With List1 If .Visible Then If KeyAscii = 32 Then x = .ListIndex If x <> -1 Then Word = FindWordPos(Text1, x1, x2) aa = Left$(Text1.Text, x1 - 1) & .List(x) & _ Chr$(KeyAscii) & Mid$(Text1.Text, x2 + 1) KeyAscii = 0 Text1.Text = aa Text1.SelStart = x1 + Len(.List(x)) .Visible = False End If End If End If End With End Sub ' aktuelles Wort ermitteln Private Function FindWordPos(TXT As Control, _ x1 As Long, x2 As Long) As String Dim x As Long Dim y As Long Dim aa As String Dim Break As String Break = vbCr & vbLf & vbTab & Chr$(32) & Chr$(160) x = Text1.SelStart + 1 x1 = 1 For y = x - 1 To 1 Step -1 aa = Mid$(Text1.Text, y, 1) If InStr(1, Break, aa) <> 0 Then x1 = y + 1 Exit For End If Next y x2 = Len(Text1.Text) For y = x To x2 aa = Mid$(Text1.Text, y, 1) If InStr(1, Break, aa) <> 0 Then x2 = y - 1 Exit For End If Next y If x2 - x1 >= 0 Then FindWordPos = Mid$(Text1.Text, x1, x2 - x1 + 1) End If End Function |