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