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 87
| Option Compare Database
Option Base 0
Function creerMotif(champ As String) As String
Dim a(25) As Byte
For i = 1 To Len(champ)
c = Asc(Mid(champ, i, 1)) - 65
a(c) = a(c) + 1
Next i
For i = 0 To 25
For j = 1 To a(i)
s = s + Chr(i + 65)
Next j
Next i
creerMotif = s
End Function
Function genCombinaison(chaine As String) As String()
Dim t() As String
Dim i As Long
Dim j As Long
n = Len(chaine)
m = 2 ^ n
ReDim t(m - 1)
For i = 0 To m - 1
mx = n - 1 'max pour éviter des décalages inutiles il faudrait: log base 2 +1
For j = 0 To mx
s = s + Mid(chaine, j + 1, SHR(i, j) And 1)
Next j
t(i) = s
s = vbNullString
Next i
genCombinaison = t
End Function
Function genCombinaison2(chaine As String) As String() 'renvoie un tableau de motif
Dim t() As String
Dim i As Long
Dim j As Long
Dim s As String
n = Len(chaine)
m = 2 ^ n
ReDim t(m - 1)
For i = 0 To m - 1
mx = n - 1 'max pour éviter des décalages inutiles il faudrait: log base 2 +1
For j = 0 To mx
s = s + Mid(chaine, j + 1, SHR(i, j) And 1)
Next j
t(i) = creerMotif(s)
s = vbNullString
Next i
genCombinaison2 = t
End Function
Sub AfficheSolus(Tirage As String)
Dim mt() As String
mt() = genCombinaison2(Tirage)
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from combinaison"
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("combinaison", dbOpenDynaset)
For i = 1 To UBound(mt)
rs.AddNew
rs!motif = mt(i - 1)
rs.Update
Next i
DoCmd.SetWarnings True
rs.Close
leSQL = "SELECT t1.mot, len(t1.mot) AS taille " & _
"FROM dico AS t1 " & _
"WHERE EXISTS (select t2.motif from combinaison t2 where t2.motif=t1.motif) " & _
"ORDER BY len(t1.mot) DESC , t1.mot;"
Set rs = CurrentDb.OpenRecordset(leSQL, dbOpenSnapshot)
While Not rs.EOF
Debug.Print rs!mot, rs!taille
rs.MoveNext
Wend
End Sub |
Partager