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