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 |
Partager