'******************************************************************************************
' Fonction : SoundEX
' Auteur : SL - AP75RILIA
' Version : 1.0
' Syntaxe : SoundEX(Mot As String) As String
' Arguments : Mot (string)
' RÈsultat : (string) : Valeur phonÈtique
' FonctionnalitÈ : Retourne la valeur phonÈtique d'un mot
' Avertissements :
' Algorithme :
'******************************************************************************************
Public Function SoundEX(Mot As String) As String
On Error GoTo ges_erreur
Dim ValeurPhonetique_Tmp As String
Dim ValeurPhonetique As String
Dim CaractereDepart As String
Dim i As Integer

' On commence par supprimer les espaces avant et aprËs le mot
ValeurPhonetique_Tmp = Trim(Mot)

' On met ensuite le mot en majuscule
ValeurPhonetique_Tmp = Format(ValeurPhonetique_Tmp, ">")

' On conserve la premiere lettre
CaractereDepart = Mid(ValeurPhonetique_Tmp, 1, 1)

' On supprime les lettres A E I O U Y H W
ValeurPhonetique_Tmp = Mid(ValeurPhonetique_Tmp, 2, Len(ValeurPhonetique_Tmp) - 1)
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "A", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "E", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "I", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "O", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "U", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "Y", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "H", "")
ValeurPhonetique_Tmp = Replace(ValeurPhonetique_Tmp, "W", "")

' Remplacement de certaine lettre par des chiffres
ValeurPhonetique = ""
For i = 1 To Len(ValeurPhonetique_Tmp)
Select Case Mid(ValeurPhonetique_Tmp, i, 1)
Case "B", "P"
If InStr(1, ValeurPhonetique, "1") = 0 Then ValeurPhonetique = ValeurPhonetique & "1"
Case "C", "K", "Q"
If InStr(1, ValeurPhonetique, "2") = 0 Then ValeurPhonetique = ValeurPhonetique & "2"
Case "D", "T"
If InStr(1, ValeurPhonetique, "3") = 0 Then ValeurPhonetique = ValeurPhonetique & "3"
Case "L"
If InStr(1, ValeurPhonetique, "4") = 0 Then ValeurPhonetique = ValeurPhonetique & "4"
Case "M", "N"
If InStr(1, ValeurPhonetique, "5") = 0 Then ValeurPhonetique = ValeurPhonetique & "5"
Case "R"
If InStr(1, ValeurPhonetique, "6") = 0 Then ValeurPhonetique = ValeurPhonetique & "6"
Case "G", "J"
If InStr(1, ValeurPhonetique, "7") = 0 Then ValeurPhonetique = ValeurPhonetique & "7"
Case "X", "Z", "S"
If InStr(1, ValeurPhonetique, "8") = 0 Then ValeurPhonetique = ValeurPhonetique & "8"
Case "F", "V"
If InStr(1, ValeurPhonetique, "9") = 0 Then ValeurPhonetique = ValeurPhonetique & "9"
End Select
Next i

ValeurPhonetique = CaractereDepart & ValeurPhonetique

' On complete par des espaces si la chaine obtenu n'a pas une longueur = 4
' Dans le cas contraire, on prend que les 4 premiers caracteres
If Len(ValeurPhonetique) < 5 Then
ValeurPhonetique = ValeurPhonetique & Space(4 - Len(ValeurPhonetique))
Else
ValeurPhonetique = Left(ValeurPhonetique, 4)
End If

SoundEX = ValeurPhonetique
Exit Function

ges_erreur:
MsgBox Err.Description, vbCritical, Err.Source
End Function