Suche nach "ähnlichem" Text

[developer]

Hi,

ich möchte eine Funktion implementieren, die in einem Textdokument nach einem bestimmten Wort/Wörter sucht. Allerdings sollen auch Wörter gefunden werden, die dem zu suchenden ähneln:

Z.B. soll er bei dem Wort Fürherschein oder Fiihrerschein auch "Führerschein" finden wenn es in der Textdatei steht.

Hat jemand schon so etwas realisiert oder weiss wo man sich SC ansehen kann?

[Jaraz]

Hi,

die ct hatte da mal was:

Sourcen sind allerdings c und Perl und nicht Basic.

http://www.heise.de/ct/ftp/99/25/252/

Der Link ist zwar von 99, das Program wird allerdings immer noch aktualisiert.

Gruß Jaraz

[developer]

Schreibe gerade eine eigene Funktion die dem "Soundex"-Algorythmus ähnelt. Verschiedenen Buchstaben werden Zahlen zugeordnet die dann verglichen werden... Sieht schon ganz gut aus...

[Peregrin]

hi,

eine (für deutsch brauchbare) implementierung in vb gibt es hier :http://www.vbarchiv.net/archiv/tipp_384.html

[Reinhold]

Original geschrieben von developer

Schreibe gerade eine eigene Funktion die dem "Soundex"-Algorythmus ähnelt. Verschiedenen Buchstaben werden Zahlen zugeordnet die dann verglichen werden... Sieht schon ganz gut aus...

Die gibt es schon fertig in der Knowhow-Datenbank von Klaus Oberdalhoff, unter anderem auf http://www.freeaccess.de

[Crush]

Au! Sowas find ich eine gute Idee - auch für eine Dateisuche, etc. Ich glaube, ich werde da mal etwas in der Art machen, wenn ich nichts Besseres finde (zwecks Dateisuche in meiner CD-Sammlung)... die Algos hier sind nicht wirklich Fehlertolerant und für echte Ähnlichkeiten auch nicht geeignet, deshalb wäre es sinnvoll das noch richtig auszubauen.

[developer]

So ungefähr hatte ich mir das vorgestellt (Beta):

Option Explicit


'*****************************************************

'Author: CSA

'Date: 06.11.03

'Compare 2 Textboxes via PSC or Soundslike

'Need:

'------------------

'Form1, Text1, Text2, Command1, Option1, Option2

'

'

'***************************BETA******************************




Private Sub Command1_Click()



    If Option1.Value = True Then

        MsgBox PercentageStrCompare(Text1.Text, Text2.Text)

    End If


    If Option2.Value = True Then

        MsgBox PercentageStrCompare(SoundsLike(Text1.Text), SoundsLike(Text2.Text))

    End If


End Sub




Public Function SoundsLike(ByVal pWord As String, _

Optional pAccuracy As Byte = 4) As String

  On Error GoTo LocalError

  '  char importance "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

  Dim x As Integer

  Dim CChar As String


  If pAccuracy > 10 Then

    pAccuracy = 10                     ' maximum accuracy allowed

  ElseIf pAccuracy < 4 Then

    pAccuracy = 4                      ' minimum accuracy allowed

  End If

  ' account for the first character

  pAccuracy = pAccuracy - 1


  pWord = UCase(pWord)


  ' strip all invalid characters

  For x = 1 To Len(pWord)

    If Asc(Mid(pWord, x, 1)) < 65 Or _

        Asc(Mid(pWord, x, 1)) > 90 Then

      Mid(pWord, x, 1) = "@"           ' assign a catchable value

    End If

  Next x

  pWord = Trim(pWord)


  SoundsLike = pWord

  ' assign values to the string

  SoundsLike = Replace(SoundsLike, "A", "0")

  SoundsLike = Replace(SoundsLike, "E", "0")

  SoundsLike = Replace(SoundsLike, "I", "0")

  SoundsLike = Replace(SoundsLike, "O", "0")

  SoundsLike = Replace(SoundsLike, "U", "0")

  SoundsLike = Replace(SoundsLike, "Y", "0")

  SoundsLike = Replace(SoundsLike, "H", "0")

  SoundsLike = Replace(SoundsLike, "W", "0")

  SoundsLike = Replace(SoundsLike, "B", "1")

  SoundsLike = Replace(SoundsLike, "P", "1")

  SoundsLike = Replace(SoundsLike, "F", "1")

  SoundsLike = Replace(SoundsLike, "V", "1")

  SoundsLike = Replace(SoundsLike, "C", "2")

  SoundsLike = Replace(SoundsLike, "S", "2")

  SoundsLike = Replace(SoundsLike, "G", "2")

  SoundsLike = Replace(SoundsLike, "J", "2")

  SoundsLike = Replace(SoundsLike, "K", "2")

  SoundsLike = Replace(SoundsLike, "Q", "2")

  SoundsLike = Replace(SoundsLike, "X", "2")

  SoundsLike = Replace(SoundsLike, "Z", "2")

  SoundsLike = Replace(SoundsLike, "D", "3")

  SoundsLike = Replace(SoundsLike, "T", "3")

  SoundsLike = Replace(SoundsLike, "L", "4")

  SoundsLike = Replace(SoundsLike, "M", "5")

  SoundsLike = Replace(SoundsLike, "N", "5")

  SoundsLike = Replace(SoundsLike, "R", "6")


  CChar = Left(SoundsLike, 1)

  For x = 2 To Len(SoundsLike)

    If Mid(SoundsLike, x, 1) = CChar Then

      Mid(SoundsLike, x, 1) = "@"

    Else

      CChar = Mid(SoundsLike, x, 1)

    End If

  Next x

  SoundsLike = Replace(SoundsLike, "@", "")


  SoundsLike = Mid(SoundsLike, 2)

  SoundsLike = Replace(SoundsLike, "0", "")


  SoundsLike = SoundsLike & String(pAccuracy, "0")

  SoundsLike = Left(pWord, 1) & Left(SoundsLike, pAccuracy)

  Exit Function

LocalError:

End Function



Public Function PercentageStrCompare(String1 As String, String2 As String, _

    Optional DoTrim As Boolean = False, Optional DoUpperCase As Boolean = False) As Integer


Dim maxlengh, minlengh As Integer

Dim i, j, k, z As Integer

Dim Pointsi, Pointsj, Pointsk As Integer

Dim Prozent As Integer



If DoTrim = True Then Trim (String1): Trim (String2)

If DoUpperCase = True Then UCase (String1): UCase (String2)



If Len(String1) > Len(String2) Then

    maxlengh = Len(String1)

    minlengh = Len(String2)

Else

    maxlengh = Len(String2)

    minlengh = Len(String1)

End If



    'Compare from left to right

    For i = 1 To minlengh

        If Mid(String1, i, 1) = Mid(String2, i, 1) Then Pointsi = Pointsi + 1

    Next i

    i = i - 1


    'Compare from right to left

    For j = 0 To minlengh - 1

        If Mid(String1, Len(String1) - j, 1) = Mid(String2, Len(String2) - j, 1) Then Pointsj = Pointsj + 1

    Next j


    'Compare from middle to end

    For k = Round(minlengh / 2) To minlengh

        If Mid(String1, k, 1) = Mid(String2, k, 1) Then Pointsk = Pointsk + 1

        z = z + 1

    Next k


    For k = Round(minlengh / 2) - 1 To 1 Step -1

        If Mid(String1, k, 1) = Mid(String2, k, 1) Then Pointsk = Pointsk + 1

        z = z + 1

    Next



    PercentageStrCompare = (Pointsi + Pointsj + Pointsk) / (i + j + z) * 100


'    MsgBox "Links " & Pointsi & " von " & i & " Übereinstimmungen" & vbCrLf _

'    & "Rechts " & Pointsj & " von " & j & " Übereinstimmungen" & vbCrLf _

'    & "Mitte " & Pointsk & " von " & z & " Übereinstimmungen" & vbCrLf _

'    & "Entspricht " & PercentageStrCompare & " %"




End Function