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: 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. Dieser Tipp wurde bereits 25.307 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
Neu! sevPopUp 2.0 Dynamische Kontextmenüs! Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |