Trouver une ressource
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum.
Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
COMPARAISON ENTRE 2 CHAINES, RETOURNE UN POURCENTAGE DE RESSEMBLANCE (DUPONT = 66,67% DE DURAND)
 Information sur la source
 Description
Bonjour, Je vous met là à disposition un fonction qui vous renvoie un pourcentage de similitude entre 2 chaînes de caractères passées en argument. Cette fonction est l'implémentation d'un modèle mathématiques (Ratcliff, Obershelp, Levenshtein), et utilise une sous-routine. Vous savez tout, vous trouverez dans l'archive jointe un projet de démonstration.
 Source
- 'Code à coller dans un module
- 'La fonction s'utilise en appelant la seule procédure publique disponible, Comparer
-
- 'implémentation de la méthode de Ratcliff, Obershelp, Levenshtein
-
- Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
- Private b1() As Byte
- Private b2() As Byte
-
- Public Function Comparer(ByVal string1 As String, ByVal string2 As String) As Double
- Dim len1 As Long
- Dim len2 As Long
- string1 = UCase$(string1)
- string2 = UCase$(string2)
- If string1 = string2 Then
- Comparer = 1
- Else
- len1 = Len(string1)
- len2 = Len(string2)
- ReDim b1(1 To len1)
- ReDim b2(1 To len2)
- RtlMoveMemory b1(1), ByVal string1, len1
- RtlMoveMemory b2(1), ByVal string2, len2
- Comparer = SubSim(1, len1, 1, len2) / (len1 + len2) * 2
- End If
- End Function
-
- Private Function SubSim(st1 As Long, end1 As Long, st2 As Long, end2 As Long) As Long
- If Not (st1 > end1 Or st2 > end2 Or st1 <= 0 Or st2 <= 0) Then
- Dim c1 As Long
- Dim c2 As Long
- Dim ns1 As Long
- Dim ns2 As Long
- Dim i As Long
- Dim max As Long
- For c1 = st1 To end1
- For c2 = st2 To end2
- i = 0
- Do Until b1(c1 + i) <> b2(c2 + i)
- i = i + 1
- If i > max Then
- ns1 = c1
- ns2 = c2
- max = i
- End If
- If c1 + i > end1 Or c2 + i > end2 Then Exit Do
- Loop
- Next c2
- Next c1
- SubSim = max + SubSim(ns1 + max, end1, ns2 + max, end2) + SubSim(st1, ns1 - 1, st2, ns2 - 1)
- End If
- End Function
'Code à coller dans un module
'La fonction s'utilise en appelant la seule procédure publique disponible, Comparer
'implémentation de la méthode de Ratcliff, Obershelp, Levenshtein
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private b1() As Byte
Private b2() As Byte
Public Function Comparer(ByVal string1 As String, ByVal string2 As String) As Double
Dim len1 As Long
Dim len2 As Long
string1 = UCase$(string1)
string2 = UCase$(string2)
If string1 = string2 Then
Comparer = 1
Else
len1 = Len(string1)
len2 = Len(string2)
ReDim b1(1 To len1)
ReDim b2(1 To len2)
RtlMoveMemory b1(1), ByVal string1, len1
RtlMoveMemory b2(1), ByVal string2, len2
Comparer = SubSim(1, len1, 1, len2) / (len1 + len2) * 2
End If
End Function
Private Function SubSim(st1 As Long, end1 As Long, st2 As Long, end2 As Long) As Long
If Not (st1 > end1 Or st2 > end2 Or st1 <= 0 Or st2 <= 0) Then
Dim c1 As Long
Dim c2 As Long
Dim ns1 As Long
Dim ns2 As Long
Dim i As Long
Dim max As Long
For c1 = st1 To end1
For c2 = st2 To end2
i = 0
Do Until b1(c1 + i) <> b2(c2 + i)
i = i + 1
If i > max Then
ns1 = c1
ns2 = c2
max = i
End If
If c1 + i > end1 Or c2 + i > end2 Then Exit Do
Loop
Next c2
Next c1
SubSim = max + SubSim(ns1 + max, end1, ns2 + max, end2) + SubSim(st1, ns1 - 1, st2, ns2 - 1)
End If
End Function
Conclusion
Merci de laisser vos commentaires, optimisations s'il y a lieu (ça me semble au top du plus du plus du plus rapide... mais bon, il y a toujours mieux... enfin peut-être !).
Si vous connaissez des fonctions du même genre, présentez les moi, je vous en serais gré !
@+
Celiphane
 Fichier Zip
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
 Télécharger le zip
Sources de la même categorie
 Commentaires
|
|