Newsgroup: it.comp.lang.visual-basic
Titolo: Ricerca parole simili in database

Salve a tutti,
all'interno di qualche sito ho trovato una funzione che era in grado di
trovare qualunque parola SIMILE a quella richiesta.
Faccio un esempio:
Con ciascuna di queste due frasi: "RAUL BOVA". o "RAOUL BOVA" ho trovato dei
link al famoso personaggio.
Io sono abituato a dover inserire una parola esatta (o porzione) per
trovarne una corrispondente con VB6.
Sapete se esiste una funzione di VB6 (o altro di simile) che possa cercare
parole simili alle chiavi di ricerca? Se si, dove posso trovarle?
Un grazie a chiunque abbia la gentilezza di rispondermi.
--
Ciao
Roberto
Email:
robert...@tiscalinet.it

 parole simili alle chiavi di ricerca? Se si, dove posso trovarle?
hai provato se l'operatore Like fa al caso tuo?
Faber


Newsgroups: it.comp.lang.visual-basic
Subject: Re: Sinonimi
Date: Sun, 31 Dec 2000 14:09:41 +0100
'#### CUT FROM HERE ####
Option Explicit
Private Const SoundexLen = 4
' equivalenze
Private Const strEquivA As String = "ءہآأؤإ"
Private Const strEquivE As String = "بةتث"
Private Const strEquivC As String = "ا"
Private Const strEquivI As String = "جحخد"
Private Const strEquivN As String = "ر"
Private Const strEquivO As String = "زسشصض"
Private Const strEquivU As String = "ظعغـ"
Private Const strEquivY As String = "فY"
' pesi
Private Const strWeight As String = "AEHIOUYWBPFVCSKGJQXZDTLMNR"
Private Const valWeight As String = "00000000111122222222334556"
Private Function IsBaseAscii(ByVal iAsciiVal As Integer) As Boolean
    IsBaseAscii = (iAsciiVal >= 65 And iAsciiVal <= 122)
End Function
Private Function IsExtAscii(ByVal iAsciiVal As Integer) As Boolean
    IsExtAscii = (IsBaseAscii(iAsciiVal) Or (iAsciiVal >= 192 And
iAsciiVal <= 221))
End Function
Private Function set_weight(ByVal strAscii As String) As String
    Dim pos As Integer
    pos = InStr(strWeight, strAscii)
    If (pos = 0) Then
        set_weight = " "
    Else
        set_weight = Mid$(valWeight, pos, 1)
    End If
End Function
Private Function filtra_Ascii(ByVal charAscii As String) As String
    Dim iAscii As Integer
    If IsExtAscii(Asc(charAscii)) Then
        If InStr(strEquivA, charAscii) <> 0 Then
            charAscii = "A"
        ElseIf InStr(strEquivE, charAscii) <> 0 Then
            charAscii = "E"
        ElseIf charAscii = strEquivC Then
            charAscii = "C"
        ElseIf InStr(strEquivI, charAscii) <> 0 Then
            charAscii = "I"
        ElseIf charAscii = strEquivN Then
            charAscii = "N"
        ElseIf InStr(strEquivO, charAscii) <> 0 Then
            charAscii = "O"
        ElseIf InStr(strEquivU, charAscii) <> 0 Then
            charAscii = "U"
        ElseIf InStr(strEquivY, charAscii) <> 0 Then
            charAscii = "Y"
        End If
        filtra_Ascii = charAscii
    Else
        filtra_Ascii = ""
    End If
End Function
Public Function soundex(ByVal sWord As String) As String
    On Error GoTo error_handler
    Dim iLen As Integer
    Dim chrTmp As String
    Dim sPesi As String
    Dim wPesi As String
    Dim tmpWeight As String
    Dim pos As Integer
    Dim i As Integer
    iLen = Len(sWord)
    ' Se la stringa e' vuota, esce.
    If (iLen = 0) Then Exit Function
    ' Converte la stringa in maiuscolo.
    sWord = UCase$(sWord)
    ' Converte lettere accentate nelle equivalenti non accentate.
    For i = 1 To iLen
        chrTmp = Mid$(sWord, i, 1)
        If Not IsBaseAscii(Asc(chrTmp)) Then
            Mid$(sWord, i, 1) = filtra_Ascii(chrTmp)
        End If
    Next
    ' Scarta punteggiatura e caratteri non appartenenti all'alfabeto.
    i = 1
    While i <= iLen
        If Not IsExtAscii(Asc(Mid$(sWord, i, 1))) Then
            sWord = Left$(sWord, i - 1) & Mid$(sWord, i + 1)
            iLen = iLen - 1
        End If
        i = i + 1
    Wend
    ' Attribuzione dei pesi.
    sPesi = Space$(iLen)
    For i = 1 To iLen
        Mid$(sPesi, i, 1) = set_weight(Mid$(sWord, i, 1))
    Next
    ' Se il 2° carattere ha lo stesso peso del 1° carattere elimina il
secondo peso.
    If Mid$(sPesi, 2, 1) = Left$(sPesi, 1) Then Mid$(sPesi, 2, 1) = 0
    ' scarta peso 1a lettera
    sPesi = Mid$(sPesi, 2)
    iLen = iLen - 1
    ' Elimina i pesi duplicati o uguali a 0.
    i = 1
    wPesi = Space$(iLen)
    While i <= iLen
        tmpWeight = Mid$(sPesi, i, 1)
        If Val(tmpWeight) <> 0 And InStr(wPesi, tmpWeight) = 0 Then
            Mid$(wPesi, i, 1) = tmpWeight
        End If
        i = i + 1
    Wend
    ' Elimina blank dalla stringa pesi.
    wPesi = Trim$(wPesi)
    pos = InStr(wPesi, " ")
    Do Until pos = 0
        wPesi = Left$(wPesi, pos - 1) & Mid$(wPesi, pos + 1)
        pos = InStr(wPesi, " ")
    Loop
    ' inserisce in testa la 1a lettera
    sPesi = Left$(sWord, 1) & wPesi
    ' se il codice e' inferiore alla lunghezza massima, accoda 0;
    ' se il codice e' superiore alla lunghezza massima, tronca il
codice.
    iLen = Len(sPesi)
    If (iLen < SoundexLen) Then
        sPesi = sPesi & String$(SoundexLen - iLen, "0")
    ElseIf (iLen > SoundexLen) Then
        sPesi = Left$(sPesi, SoundexLen)
    End If
    ' Restituisce il codice soundex.
    soundex = sPesi
    Exit Function
error_handler:
    Err.Raise Err.Number, "soundex", Err.Description
End Function

 ha scritto

funzione soundex, non mi ricordo mai se in vb c'e', ma se ne e' discusso
tempo fa sul ng, con google dovrebbe saltar fuori.
ciao, a.

Grazie infininte a voi. Adesso provo.


 >trovarne una corrispondente con VB6.
[...]


Splendida.
ciao
ugo