Korrektes finden kleinerer und grösserer Wörter...
08.03.2003 22:51:33
Ramses
Hallo, hier das Finetuning :-))
und der zugehörige Code:
Private Sub btnStringSearch_Click()
'(C) Ramses
Dim strOrig As String, strSearch As String
Dim strVal As Double, strLen As Integer, strGoal As Double
Dim i As Integer, j As Integer, n As Integer, findOne As Boolean ' für die weitere Verfeinerung :-)
'Listbox leeren
Me.ListBox1.Clear
'Variablen füllen
'Der zu durchsuchende String
strOrig = Me.TextBox3
'Der zu suchende String
strSearch = Me.TextBox1
strLen = Len(Me.TextBox1)
findOne = False
'Werte ermitteln
'Der prozentuale Wert
'Wert prüfen
If CDbl(Me.TextBox2.Value) > 100 Or CDbl(Me.TextBox2.Value) < 50 Then
MsgBox ("Diese Wertangaben ergeben keinen Sinn")
Exit Sub
End If
'Eingabe in Zahlenwert umwandeln
strVal = CDbl(Me.TextBox2)
'Gewünschte Übereinstimmungslänge ermitteln
strGoal = Int((Len(strSearch) / 100) * strVal)
'maximale Wortlänge für nicht exakt übereinstimende Wörter
n = 50
'Suche starten
For i = 1 To Len(strOrig)
If Mid(strOrig, i, strGoal) = Left(strSearch, strGoal) Then
If strVal = 100 Then
'Bei 100% erfolgt der Eintrag direkt
Me.ListBox1.AddItem Mid(strOrig, i, Len(strSearch))
findOne = True
End If
If strVal < 100 Then
'bei reduzierter Genauigkeit wird versucht zuerst die Auswalh
'zu verkleinern um Leerzeichen zu finden damit ein ganzes
'Wort identifiziert werden kann
Debug.Print "gefundener minimalstring " & Mid(strOrig, i, strGoal)
For j = Len(Mid(strOrig, i, strGoal)) To 1 Step -1
If Mid(Mid(strOrig, i, strGoal), j, 1) = " " Then
Me.ListBox1.AddItem Left(Mid(strOrig, i, Len(strSearch)), Len(Mid(strOrig, i, strGoal)) - j)
findOne = True
Exit For
End If
Next j
End If
If findOne = False Then
'Wenn kein abschliessendes Wort gefunden werden kann
'wird die Suche bis auf n vergrössert um das nächste
'zutreffende Wort zu finden
For j = i To (i + 50)
If Mid(strOrig, j, 1) = " " Then
Me.ListBox1.AddItem Mid(strOrig, i, j - i)
Exit For
End If
Next j
End If
'finden zurücksetzen
findOne = False
End If
Next i
End Sub
Code eingefügt mit Syntaxhighlighter 1.16
Gruss Rainer