title image


Smiley probiere mal etwas, sollte sogar selbst lernen ....


Option Explicit





' Textbox auf Userform

' Code auf Userform

' Das Programm lernt auf dem Blatt Worte

' verliert die Textbox den Focus, merkt sich Excel die Eingabe



' probiere mal etwas rum ... habe nicht alles geprueft



Private Const STARTSPALTE = 1

Private Const WORTE_TAB = "Worte"

Private tb_lock As Boolean, tmp$, rng As Range, blocke_autokorrektur As Boolean





Private Sub TextBox1_Change()

Dim ln&

    If blocke_autokorrektur Then

      blocke_autokorrektur = False

      Exit Sub

    End If

    If tb_lock Then Exit Sub

    tb_lock = True

    ln = Len(TextBox1)

        tmp = Finde_Vorschlag(TextBox1.Value)

        If tmp <> vbNullString Then

            With TextBox1

                .Value = tmp

                .SelStart = ln

                .SelLength = Len(TextBox1)

            End With

        End If

    tb_lock = False

End Sub





Private Function Finde_Vorschlag(eingabe$) As String

Dim fa$, fd As Boolean

    If eingabe = " " Or eingabe = vbNullString Then

        Finde_Vorschlag = vbNullString

        Exit Function

    End If

    With Worksheets(WORTE_TAB).Cells

    

        Set rng = .Find(eingabe, LookIn:=xlValues, lookat:=xlPart)

        If Not rng Is Nothing Then

            fa = rng.Address

            Do

              If Left(rng.Value, Len(eingabe)) = eingabe Then

                fd = True

                Exit Do

              End If

              Set rng = .FindNext(rng)

            Loop While Not rng Is Nothing And rng.Address <> fa

        If Not fd Then

            Finde_Vorschlag = vbNullString

            Exit Function

        Else

            Finde_Vorschlag = .Cells(rng.Row, rng.Column).Value

        End If

     End If

    End With



End Function



Private Sub textbox1_afterUpdate()

' Worte werden in einem Feld von 256 x 65536 gespeichert, muesste ja reichen :o)

Dim rn As Range, rw&, col%

    If rng Is Nothing Then   ' Vorschlag wurde nicht benutzt also Wort speichern

        With Worksheets(WORTE_TAB)

            Set rn = .UsedRange  ' naechsten freien Platz finden

            ' rw und col der Uebersichtlichkeit halber

            If .Cells(rn.Row, .Cells.Columns.Count) = vbNullString Then

                col = .Cells(rn.Row, Cells.Columns.Count).End(xlToLeft).Column + 1

                rw = rn.Row

            Else

                rw = rn.Row + 1

                col = 1

            End If

            .Cells(rw, col).Value = TextBox1

        End With

    Set rn = Nothing: Set rng = Nothing

    End If

    

End Sub



Private Sub Textbox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal shift As Integer)

    If KeyCode = 8 Then blocke_autokorrektur = True

    If Len(TextBox1) = 0 Then blocke_autokorrektur = False

End Sub



 Code eingefügt mit Syntaxhighlighter 1.16

Knofi So wie wir heute arbeiten, werden morgen die Beamten leben ...

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: