FONCTION SOUNDEX EN VISUAL BASIC 6

Public Function Analyse_Homonyme(ByVal NomActeur As String)

ValeurCaractere = ""

'passage en majuscule et suppression des espaces
NomActeur = UCase(NomActeur)
'NomActeur = UCase("ZARA WHITE")
NomActeur = Replace(NomActeur, " ", "")
caracteredepart = Mid(NomActeur, 1, 1)

'Elimination des voyelles du H et du W
For i = 1 To Len(NomActeur)
    caractere = Mid(NomActeur, i, 1)
    Select Case caractere
        Case "A", "E", "I", "O", "U", "Y"
            NouveauNom = NouveauNom
        Case "H", "W"
            NouveauNom = NouveauNom
        Case Else
            NouveauNom = NouveauNom + caractere
    End Select
Next

'Analyse du NouveauNom
For i = 1 To Len(NouveauNom)
    caractere = Mid(NouveauNom, i, 1)
    Select Case caractere
        Case "B", "F", "P", "V"
            ValeurCaractere = ValeurCaractere & 1
        Case "C", "G", "J", "K", "Q", "S", "X", "Z"
            ValeurCaractere = ValeurCaractere & 2
        Case "D", "T"
            ValeurCaractere = ValeurCaractere & 3
        Case "L"
            ValeurCaractere = ValeurCaractere & 4
        Case "M", "N"
            ValeurCaractere = ValeurCaractere & 5
        Case "R"
            ValeurCaractere = ValeurCaractere & 6
        End Select
Next

Mot_Code = ValeurCaractere
'si la longeur est superieure a 4  je ne garde que les 4 premiers
If Len(ValeurCaractere) >= 4 Then Mot_Code = Mid(Mot_Code, 1, 4)

'NouveauNom Codé --> Elimination des Doublons consécutifs
For i = 1 To Len(ValeurCaractere)
    caractere = Mid(ValeurCaractere, i, 1)
    Select Case caractere
        Case "1"
            ' je remonte d une lettre pour verifier les eventuels doublons
            If i > 1 Then
                LettrePrec = Mid(Mot_Code, i - 1, 1)
                valeur = LettrePrec & 1
            End If
            If valeur = "11" Then
                PositionPaire = InStr(1, Mot_Code, valeur)
                Paire (PositionPaire)
            End If
        Case "2"
            ' je remonte d une lettre pour verifier les eventuels doublons
            If i > 1 Then
                LettrePrec = Mid(Mot_Code, i - 1, 1)
                valeur = LettrePrec & 2
            End If
            If valeur = "22" Then
                PositionPaire = InStr(1, Mot_Code, valeur)
                Paire (PositionPaire)
            End If
        Case "3"
            ' je remonte d une lettre pour verifier les eventuels doublons
            If i > 1 Then
                LettrePrec = Mid(Mot_Code, i - 1, 1)
                valeur = LettrePrec & 3
            End If
            If valeur = "33" Then
                PositionPaire = InStr(1, Mot_Code, valeur)
                Paire (PositionPaire)
            End If
        Case "4"
            ' je remonte d une lettre pour verifier les eventuels doublons
            If i > 1 Then
                LettrePrec = Mid(Mot_Code, i - 1, 1)
                valeur = LettrePrec & 4
            End If
            If valeur = "44" Then
                PositionPaire = InStr(1, Mot_Code, valeur)
                Paire (PositionPaire)
            End If
        Case "5"
            ' je remonte d une lettre pour verifier les eventuels doublons
            If i > 1 Then
                LettrePrec = Mid(Mot_Code, i - 1, 1)
                valeur = LettrePrec & 5
            End If
            If valeur = "55" Then
                PositionPaire = InStr(1, Mot_Code, valeur)
                Paire (PositionPaire)
            End If
        Case "6"
            ' je remonte d une lettre pour verifier les eventuels doublons
            If i > 1 Then
                LettrePrec = Mid(Mot_Code, i - 1, 1)
                valeur = LettrePrec & 6
            End If
            If valeur = "66" Then
                PositionPaire = InStr(1, Mot_Code, valeur)
                Paire (PositionPaire)
            End If
        End Select
        If Resultat_Paire <> "" Then
            Mot_Code = Resultat_Paire
        End If
Next

ValeurCaractere = caracteredepart & Mot_Code
If Len(ValeurCaractere) > 4 Then
    ValeurCaractere = Mid(ValeurCaractere, 1, 4)
Else
    For i = 1 To (4 - Len(ValeurCaractere))
        ValeurCaractere = ValeurCaractere & 0
    Next
End If

End Function

Public Function Paire(ByVal Position As Integer)
    
    chaine1 = ""
    chaine2 = ""
    Resultat_Paire = ""
    ' je recupere la valeur avant le premier doublon
    chaine1 = Mid(Mot_Code, 1, PositionPaire)
    longueurrecupere = Len(chaine1)
    If longueurrecupere >= 3 Then
        chaine2 = ""
    Else
        ' si la position du premier doublon est autre que 1
        If Position = 1 Then
            ' j elimine le caractere de trop
            chaine2 = Mid(Mot_Code, PositionPaire + 2, PositionPaire + 2)
        Else
            chaine2 = Mid(Mot_Code, PositionPaire + 2, 1)
        End If
    End If
    Resultat_Paire = chaine1 & chaine2

End Function

21 janvier 2007 12:11:44 :

Oupss j'ai oublié de préciser que la fonction Soundex est une recherche "phonétique" sur un ou plusieurs mots. Chaque mot est codé selon un algorythme donné. il suffit ensuite de comparer les résultats obtenus pour trouver les éventuels homonynes dans la base de données.

22 janvier 2007 11:10:04 :

le 22/01/2007 Y avait un bug........et j ai un peu optimisé la chose...............les tests semblent corrects...........

03 février 2007 20:15:43 :

Une précision s impose........... du fait des differences de langage, (Anglais/Americain et Francais) les prononciatioins ne sont pas les mêmes. La fonction Soundex codée ici est la version Anglaise. La version Française comporte quelques différences dans la valeur des lettres. Un peu de pub maintenant ;) Cette fonction s'intègre dans un logiciel de Gestion de vidéothèque qui hormis les fonctions classiques d'ajout, modification et suppression de films comprend les fonctionnalités suivantes : - Gestion des Prêts - Enregistrement semi automatique des films depuis Internet (Récupérations des Acteurs, du Titre, du Résumé du film etc etc..) - Gestion des jaquettes Vidéos et des photos d'acteurs - Visualisation du film possible depuis l'application (WMPlayer) - Multi Bases (Sql et Access) - Nombreuses Statistiques et Editions......... - Evolutions futures : Gestion des Editions via Crystal Report... pour le moment c est le bloc notes via un fichier texte...... Voila.......... je m'occupe comme je peux lol