Fonction soundex en visual basic 6

Soyez le premier à donner votre avis sur cette source.

Snippet vu 7 704 fois - Téléchargée 25 fois

Contenu du snippet

Ayant écrit un logiciel de gestion de vidéothèque je me suis aperçu que l'on pouvait vite avoir des soucis avec des noms d'acteurs mal orthographiés... Ex Bruce Willsi à la place de Bruce Willis....... J'ai donc traduit la fonction Soundex (Recherche phonétique) décrite notament par Frédéric Brouard avec qui j'ai bossé (dans une galère.....dans le Var..il devrait reconnaître !!!!) en VB 6.

Source / Exemple :


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

A voir également

Ajouter un commentaire

Commentaires

capricorne83
Messages postés
48
Date d'inscription
mercredi 25 mai 2005
Statut
Membre
Dernière intervention
15 novembre 2013
-
@Thom

Merci de ton commentaire, j'y apporterai les précisions suivantes ainsi que je l'ai expliqué plus haut cette version est la version anglophone. Les accents ne sont donc pas gérés. De même que je passe systématiquement le nom à tester en majuscules je ne me préoccupes pas des caractères accentués. Pour ce qui est du cas des deux lettres consécutives, je le gére a partir de la ligne 48.
thomthom63
Messages postés
2
Date d'inscription
lundi 9 mai 2005
Statut
Membre
Dernière intervention
3 avril 2007
-
Salut!
Ton code est pas mal du tout, mais je vois au moins deux points sur lesquels tu peux apporter une amélioration:
_ Ne pas prendre en compte les caractères accentués, car ton algo fait la distinction entre "é", "è" et "e"
_ Ne pas tenir compte des lettre consécutives identiques, pour ceux qui ne savent pas que "Pomme" prend deux "M" par exemple.

Sinon, c'est du bon boulot!

Thom
capricorne83
Messages postés
48
Date d'inscription
mercredi 25 mai 2005
Statut
Membre
Dernière intervention
15 novembre 2013
-
Bin...... dans une videotheque y a pas forcement que du blanche neige et les sept nains ;)
Nix
Messages postés
838
Date d'inscription
samedi 15 mai 1999
Statut
Modérateur
Dernière intervention
18 juillet 2009
-
Ligne 7 : 'NomActeur = UCase("ZARA WHITE")

... Je me demande bien pour quel usage était prévu ce code initialement :-D
thierrydelepine
Messages postés
521
Date d'inscription
mardi 24 décembre 2002
Statut
Membre
Dernière intervention
11 septembre 2008
2 -
code tres interressant, c'est vraiment une fonction qui peut servir.

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.