Kölner Phonetik Phonetische Namenscodierung ähnlich Soundex
Autor:   Thomas Gollmer	Bewertung:     [ Jetzt bewerten ]	Views:  25.289
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 25 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 4.8 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

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.