[Fait]API - Enlever les accents d'une chaîne [FAQ]

[cafeine]

En complément à la fonction de Tofalu qui passe par une énumération des différents caractères accentués.

http://access.developpez.com/faq/?pa...s#IgnAccentSQL

Voici une solution plus rapide par les API.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Declare Function FoldString Lib "kernel32.dll" Alias _
        "FoldStringA" (ByVal dwMapFlags As Long, ByVal lpSrcStr As Long, _
        ByVal cchSrc As Long, ByVal lpDestStr As Long, ByVal cchdest As Long) As Long
 
Function OteAccents(ByVal str As String) As String
 
    Dim i As Integer
    OteAccents = Space(Len(str))
 
    For i = 0 To (Len(str) - 1) * 2 Step 2
        FoldString &H40, StrPtr(str) + i, 1, StrPtr(OteAccents) + i, 1
    Next i
 
End Function

[philben]

bonjour,

ci-dessous une fonction de comparaison des 3 méthodes sur la qualité et la rapidité des résultats :

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
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
 
Private Declare Function FoldString Lib "kernel32.dll" Alias _
            "FoldStringA" (ByVal dwMapFlags As Long, ByVal lpSrcStr As Long, _
           ByVal cchSrc As Long, ByVal lpDestStr As Long, ByVal cchdest As Long) As Long
 
Public Sub TestConversion()
   Const clNbConversion As Long = 50000
   Const csTest As String = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöùúûüýÿ"
   Const csResult As String = "AAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy"
   Dim fT0 As Single, fDT As Single
   Dim sConv As String, sMsg As String
   Dim iMethode As Integer, j As Long
   For iMethode = 1 To 3
      Select Case iMethode
      Case 1
         fT0 = Timer
         For j = 1 To clNbConversion
            sConv = sansAccent(csTest, False)
         Next j
         fDT = Timer - fT0
      Case 2
         fT0 = Timer
         For j = 1 To clNbConversion
            sConv = OteAccents(csTest)
         Next j
         fDT = Timer - fT0
      Case 3
         fT0 = Timer
         For j = 1 To clNbConversion
            sConv = NoAccent(csTest, vbNarrow)
         Next j
         fDT = Timer - fT0
      End Select
      SetMessage sMsg, iMethode, fDT, csTest, csResult, sConv
   Next iMethode
   MsgBox sMsg, vbInformation, _
          "Comparaison de la qualité et de la rapidité des 3 méthodes de conversion"
End Sub
 
Private Sub SetMessage(sMsg As String, ByVal iMethode As Integer, ByVal fTime As Single, _
                       ByVal sInit As String, ByVal sAtt As String, sConv As String)
   sMsg = sMsg & vbCrLf & vbCrLf
   sMsg = sMsg & "Méthode n°" & iMethode & vbCrLf & String(16, "-") & vbCrLf
   sMsg = sMsg & vbTab & "Chaîne initiale : " & vbTab & sInit & vbCrLf
   sMsg = sMsg & vbTab & "Chaîne attendue : " & vbTab & sAtt & vbCrLf
   sMsg = sMsg & vbTab & "Chaîne obtenue : " & vbTab & sConv & vbCrLf & vbCrLf
   sMsg = sMsg & vbTab & "Conversion Ok ? " & vbTab & IIf(InStr(1, sAtt, sConv, vbBinaryCompare) = 1, "Oui", "Non") & vbCrLf
   sMsg = sMsg & vbTab & "Durée conversion : " & vbTab & Format(fTime, "0.000s")
End Sub
 
'Méthode n°1 : Tofalu
Public Function sansAccent(ByVal Chaine As String, EnMajuscule As Boolean) As String
   Chaine = LCase(Chaine)
   Chaine = Replace(Chaine, Chr(232), "e")
   Chaine = Replace(Chaine, Chr(233), "e")
   Chaine = Replace(Chaine, Chr(234), "e")
   Chaine = Replace(Chaine, Chr(235), "e")
   Chaine = Replace(Chaine, Chr(249), "u")
   Chaine = Replace(Chaine, Chr(250), "u")
   Chaine = Replace(Chaine, Chr(251), "u")
   Chaine = Replace(Chaine, Chr(242), "o")
   Chaine = Replace(Chaine, Chr(244), "o")
   Chaine = Replace(Chaine, Chr(254), "o")
   Chaine = Replace(Chaine, Chr(255), "y")
   Chaine = Replace(Chaine, Chr(224), "a")
   Chaine = Replace(Chaine, Chr(225), "a")
   Chaine = Replace(Chaine, Chr(226), "a")
   Chaine = Replace(Chaine, Chr(238), "i")
   Chaine = Replace(Chaine, Chr(239), "i")
   If EnMajuscule Then Chaine = UCase(Chaine)
   sansAccent = Chaine
End Function
 
'Méthode n°2 : Caféine
Function OteAccents(ByVal str As String) As String
   Dim i As Integer
   OteAccents = Space(Len(str))
   For i = 0 To (Len(str) - 1) * 2 Step 2
      FoldString &H40, StrPtr(str) + i, 1, StrPtr(OteAccents) + i, 1
   Next i
End Function
 
'Méthode n°3 : PhilBen
Public Function NoAccent(sChaine As String, vbCase As VbStrConv) As String
   NoAccent = StrConv(sChaine, vbCase, 4)
End Function

Cordialement,

Philippe

Edition :
Ajout d'un comparatif des conversions effectuées selon la méthode utilisée et le Local ID de StrConv.