Rubrik: Variablen/Strings · Algorithmen/Mathematik | VB-Versionen: VB6 | 15.01.08 |
Kölner Phonetik Phonetische Namenscodierung ähnlich Soundex | ||
Autor: Thomas Gollmer | Bewertung: | Views: 25.289 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
In einem anderen Tipp wird der SoundEx-Algorithmus vorgestellt, um zwei Wörter phonetisch zu vergleichen. Der Nachteil dabei ist, dass das System eigentlich für die englische Sprache gedacht ist. Desweiteren fließt der Anfangsbuchstabe des Wortes in den Code ein.
Hier wird nun der Quellcode für das Verfahren "Kölner Phonetik" vorgestellt. Dieses System ist der deutschen Sprache angelehnt und bringt meiner Meinung bessere Ergebnisse als der SoundEx-Code. Das muss allerdings jeder selbst beurteilen.
Im Gegensatz zum SoundEx, bei welchem der Code immer 4 Zeichen lang ist, ist der hier erzeugte Code variabler Länge und abhängig von der eigentlichen Wortlänge.
Hier nun der Code:
Private Function Koelner_Phonetic(ByVal Eingabe As String) As String ' Für Zeichen und nicht deutsche Buchstaben wird "?" im ' String zurück gegeben Dim Rückgabe As String Dim Zähler As Integer Dim Kette As String Dim Wert As String Dim Endwert As String ' Leerzeichen weg Eingabe = Trim(Eingabe) ' Kleinbuchstaben Eingabe = LCase$(Eingabe) ' Sonderzeichen umwandeln Eingabe = Replace(Eingabe, "ph", "f") Eingabe = Replace(Eingabe, "ü", "u") Eingabe = Replace(Eingabe, "ä", "a") Eingabe = Replace(Eingabe, "ö", "o") Eingabe = Replace(Eingabe, "ß", "ss") ' Start und Endmarkierung anhängen Eingabe = "#" & Eingabe Eingabe = Eingabe & "#" ' Zeichen mit Vorgänger und Nachfolger einlesen ' und in ZiffernWert wandeln For Zähler = 1 To Len(Eingabe) - 2 Kette = Mid$(Eingabe, Zähler, 3) If Zähler = 1 Then Wert = Conv_Ersten(Kette) Else Wert = Conv_Rest(Kette) End If Rückgabe = Rückgabe & Wert Next ' "h" = "-" komplett löschen Rückgabe = Replace(Rückgabe, "-", "") ' "0" außer am Anfang löschen If Left$(Rückgabe, 1) = "0" Then Rückgabe = "0" & Replace(Rückgabe, "0", "") Else Rückgabe = Replace(Rückgabe, "0", "") End If ' Doppelte entfernen Endwert = Left$(Rückgabe, 1) For Zähler = 2 To Len(Rückgabe) If Mid$(Rückgabe, Zähler, 1) <> Right$(Endwert, 1) Then Endwert = Endwert & Mid$(Rückgabe, Zähler, 1) End If Next ' Rückgabe Koelner_Phonetic = Endwert End Function
Private Function Conv_Ersten(ByVal Kette As String) As String ' Sonderfälle für Wortanfang (Reihenfolgen NICHT ändern) If Mid$(Kette, 2, 1) = "a" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 1) = "e" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 1) = "i" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 1) = "j" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 1) = "y" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 1) = "o" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 1) = "u" Then Conv_Ersten = "0": Exit Function If Mid$(Kette, 2, 2) = "ca" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "ch" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "ck" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "cl" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "co" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "cq" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "cr" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "cu" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 2) = "cx" Then Conv_Ersten = "4": Exit Function If Mid$(Kette, 2, 1) = "c" Then Conv_Ersten = 8: Exit Function ' Alle anderen Anfangsbuchstaben wie Rest Dim InVal As String Dim RetVal As String InVal = Kette RetVal = Conv_Rest(InVal) Conv_Ersten = RetVal End Function
Private Function Conv_Rest(ByVal Kette As String) As String ' Reihenfolgen NICHT ändern ' Zeichenfolgen If Mid$(Kette, 2, 2) = "ds" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 2) = "dc" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 2) = "dz" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 2) = "ts" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 2) = "tc" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 2) = "tz" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 1) = "d" Then Conv_Rest = "2": Exit Function If Mid$(Kette, 2, 1) = "t" Then Conv_Rest = "2": Exit Function If Mid$(Kette, 1, 2) = "cx" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 1, 2) = "kx" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 1, 2) = "qx" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 1) = "x" Then Conv_Rest = "48": Exit Function If Mid$(Kette, 1, 2) = "sc" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 1, 2) = "sz" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 2) = "ca" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 2) = "co" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 2) = "cu" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 2) = "ch" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 2) = "ck" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 2) = "cx" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 2) = "cq" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 1) = "c" Then Conv_Rest = "8": Exit Function ' Einzelbuchstaben If Mid$(Kette, 2, 1) = "a" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "e" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "i" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "j" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "y" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "o" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "u" Then Conv_Rest = "0": Exit Function If Mid$(Kette, 2, 1) = "h" Then Conv_Rest = "-": Exit Function If Mid$(Kette, 2, 1) = "l" Then Conv_Rest = "5": Exit Function If Mid$(Kette, 2, 1) = "r" Then Conv_Rest = "7": Exit Function If Mid$(Kette, 2, 1) = "m" Then Conv_Rest = "6": Exit Function If Mid$(Kette, 2, 1) = "n" Then Conv_Rest = "6": Exit Function If Mid$(Kette, 2, 1) = "s" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 1) = "z" Then Conv_Rest = "8": Exit Function If Mid$(Kette, 2, 1) = "b" Then Conv_Rest = "1": Exit Function If Mid$(Kette, 2, 1) = "p" Then Conv_Rest = "1": Exit Function If Mid$(Kette, 2, 1) = "f" Then Conv_Rest = "3": Exit Function If Mid$(Kette, 2, 1) = "v" Then Conv_Rest = "3": Exit Function If Mid$(Kette, 2, 1) = "w" Then Conv_Rest = "3": Exit Function If Mid$(Kette, 2, 1) = "g" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 1) = "k" Then Conv_Rest = "4": Exit Function If Mid$(Kette, 2, 1) = "q" Then Conv_Rest = "4": Exit Function ' Error Conv_Rest = "?" End Function
Kleine Beispielanwendung:
Ein neues Projekt erstellen und dort eine Textbox (Text1), einen Command Button (Command1) und eine Listbox (List1) auf dem Formular plazieren. Bei der Listbox die "MultiSelect"-Eigenschaft
auf "Einfach = 1" setzten und folgenden Code einfügen:
Private Sub Form_Load() ' Liste mit Einträgen füllen With List1 .AddItem "Müller" .AddItem "Miller" .AddItem "Mueller" .AddItem "Mühler" .AddItem "Mühlherr" .AddItem "Mülherr" .AddItem "Myler" .AddItem "Millar" .AddItem "Myller" .AddItem "Müllar" .AddItem "Müler" .AddItem "Muehler" .AddItem "Mülller" .AddItem "Müllerr" .AddItem "Muehlherr" .AddItem "Muellar" .AddItem "Mueler" .AddItem "Mülleer" .AddItem "Mueller" .AddItem "Nüller" .AddItem "Nyller" .AddItem "Niler" .AddItem "Czerny" .AddItem "Tscherny" .AddItem "Czernie" .AddItem "Tschernie" .AddItem "Schernie" .AddItem "Scherny" .AddItem "Scherno" .AddItem "Czerne" .AddItem "Zerny" .AddItem "Tzernie" End With End Sub
Private Sub Command1_Click() Dim Suchname As String Dim Fundname As String Dim Counter As Long ' Suchname wandeln Suchname = Text1.Text Suchname = Koelner_Phonetic(Suchname) ' Liste durchlaufen With List1 For Counter = 0 To .ListCount - 1 Fundname = .List(Counter) ' Fundname wandeln Fundname = Koelner_Phonetic(Fundname) ' Wenn Übereinstimmung, Listeneintrag markieren If Fundname = Suchname Then .Selected(Counter) = True Else .Selected(Counter) = False End If Next End With End Sub
In der Textbox kann nun ein Suchname eingegeben werden, und mit Klick auf den Command Button werden alle phonetisch ähnlichen Wörter in der Listbox markiert.
Besonders fällt die Überlegenheit gegenüber Soundex auf, wenn nach dem Namen "Czerny" gesucht wird.