Fonction qui supprime les accents des caractères

Salut

Suite à cette discussion

Donc voici la fonction qui fait le travail

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Function SuppAccents(TextAtraiter)
Dim RegularExpressioN, T, U
Dim ListPattern, TblPattern
Dim ListSubstit, TblSubstit
 
'création du tableau de Pattern en 2 étapes
'       1er étape: création de la liste caractères accentués, en MAJUSCULES et minuscules
ListPattern = "À|Á|Â|Ã|Ä|Å Ç È|É|Ê|Ë Ì|Í|Î|Ï Ñ Ò|Ó|Ô|Õ|Ö|Ø Ù|Ú|Û|Ü Ý|Ÿ Ž " _
            & "š à|á|â|ã|ä|å ç è|é|ê|ë ì|í|î|ï ñ ð|ò|ó|ô|õ|ö|ø ù|ú|û|ü ý|ÿ"
'       2éme étape: création du tableau de Pattern
TblPattern = Split(ListPattern, " ", -1, vbTextCompare)
 
'création du tableau de substitution des caractères accentués en caractères non accentués
ListSubstit = "A C E I N O U Y Z s a c e i n o u y"     ' création de la liste
TblSubstit = Split(ListSubstit, " ", -1, vbTextCompare) ' création du tableau
 
Set RegularExpressioN = New RegExp 'VBScript Regular Expressions et natif sous VBScript
RegularExpressioN.Global = True 'appliquer le remplacement à tout le texte
SuppAccents = TextAtraiter
U = UBound(TblPattern)
For T = 0 To U
    RegularExpressioN.Pattern = TblPattern(T) 'caractère(s) à rechercher
    ' Effectue le remplacement appliquer à tout le texte
    SuppAccents = RegularExpressioN.Replace(SuppAccents, TblSubstit(T))
Next
 
Set RegularExpressioN = Nothing
End Function

Pour l'utilisation:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
dim TextSoumis, TextRetour
 
TextSoumis = "Voici un texte avec des caractères accentués, la fonction va retournée" _
            & vbNewline & "ce même texte sans plus aucun caractère accentué"
TextRetour = SuppAccents(TextSoumis)
MsgBox "Texte soumis:" & vbnewline & TextSoumis & vbnewline & vbnewline _
     & "Texte en retour:" & vbnewline & TextRetour, vbinformations,"sans accents" 
 
' ou bien
TextRetour = SuppAccents("Voici un texte avec des caractères accentués, la fonction va retournée" _
            & vbNewline & "ce même texte sans plus aucun caractère accentué")
MsgBox TextRetour
 
' ou encore directement
MsgBox SuppAccents("Voici un texte avec des caractères accentués, la fonction va retournée" _
            & vbNewline & "ce même texte sans plus aucun caractère accentué")