vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Zippen wie die Profis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Variablen/Strings · Algorithmen/Mathematik   |   VB-Versionen: VB615.01.08
Kölner Phonetik

Phonetische Namenscodierung ähnlich Soundex

Autor:   Thomas GollmerBewertung:     [ Jetzt bewerten ]Views:  20.521 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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.

Dieser Tipp wurde bereits 20.521 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel