Discussion :

[drakakoo]

Bonjour,

Dans le cadre du développement d'une application, je souhaite pouvoir générer une clé d'activation alphanumérique sur 12 positions à partir d'une chaine de caractère.

Auriez-vous une fonction pour faire cela ? et le top serait de pouvoir régénérer la chaine de caractère à partir de la clé d'activation.

Merci à tous pour l'aide.

[marot_r]

Bonjour.

A priori sauf si tu fais l'équivalent d'une compression, ce genre de transformation est à sens unique. Du clair vers le code.

Tu peux regarder du côté des fonction de hachages ("Hash function" en anglais), il en existe plein de sortes.
En résumé : elles regardent les caractères comme des nombres et font des calculs sur ces nombres pour les ramener à un interval donné.
Ici un article en français sur le sujet.
Fonction de hachage
https://fr.wikipedia.org/wiki/Fonction_de_hachage

Sinon, tu peux aussi t'orienter vers un simple échantillonage de 1 caractère tous les X caractères de ta chaîne d'origine.
Avec X = Longeur Totale chaîne / 12 ou pour meller un peu les cartes X = Longeur Totale chaîne / 6 et tu affiches le code Ascii en Hexadécimal.
Évidement il y a de forte chance que plusieurs chaînes différentes génèrent la même série en final.

Pour la compression ("text compression" en anglais), en gros, tu regardes la chaîne et tu la décrit.
C'est un peu comme une factorisation.
Ici un article en français sur le sujet.
Compression de données
https://fr.wikipedia.org/wiki/Compression_de_données

Mais avec une limite de 12 caractères, il est peu probable que tu puisses revenir à la chaîne d'origine.

A+

[Ric500]

Salut çà vaut ce que çà vaut, mais ce module a répondu à pas mal de mes attentes:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
Option Compare Database
 
Option Explicit
Option Private Module
'----------------------------------------------------
' Exemple de génération de clé HEXA (0 à 9 et A à F)
'----------------------------------------------------
' Pour personnaliser votre clé, modifier la valeur de gModulo
'     et des multiplicateur dans la fonction GetMult
' Conservez la fonction GenerateKey hors de l'application
'
'----------------------------------------------------
 
' Modulo : Le Checksum doit être multiple de ce nombre
' Ce nombre doit être inférieur à la somme des multiplicateur * 15
Private Const gModulo = 480
 
' Clé de cryptage
Private Const CLEF As String = "A45RGT5FER6745GHTOGFSDOPK56453235K"
 
' Nombre d'itérations de la fonction maximum
Private Const NBROTATIONSMAX       As Long = 13
 
' Valeurs possibles
Private Const gValues = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 
Function DaysLeftK(sKey)
    DaysLeftK = CLng("&H" & Mid(sKey, 3, Mid(sKey, 2, 1))) - CLng(DateValue(Now))
End Function
 
 
' Multiplicateurs pour calcul du checksum
Private Function GetMult(pNum As Integer) As Integer
    Select Case pNum
        Case 1: GetMult = 10
        Case 2: GetMult = 13
        Case 3: GetMult = 9
        Case 4: GetMult = 11
        Case 5: GetMult = 14
        Case 6: GetMult = 12
        Case 7: GetMult = 3
        Case 8: GetMult = 2
        Case 9: GetMult = 7
        Case 10: GetMult = 6
        Case 11: GetMult = 5
        Case 12: GetMult = 4
        Case 13: GetMult = 8
        Case 14: GetMult = 15
        Case 15: GetMult = 1 ' Doit être égale à 1
    End Select
End Function
 
' Vérifie si la clé est correcte
' Si la clé a été générée avec une date, vérifie si pValidDate est inférieur ou égale à cette date
Public Function CheckKey(ByVal sKey As String, Optional pValidDate As Date) As Boolean
    On Error GoTo gestion_erreurs
    Dim lDate As Date
    ' Clé vide invalide
    If Len(sKey) = 0 Then
        CheckKey = False
        Exit Function
    End If
    ' Calcul du checksum
    If (GetCheckSum(sKey) Mod gModulo) = 0 Then
        ' Vérifie si la date est valide
        ' La date commence au troisième caractère si le premier caractère est D,
        '    sa longueur est écrite dans le deuxième caractère
        If Mid(sKey, 1, 1) = "D" Then ' On a codé une date dans la clé
           If pValidDate = Format("00:00:00") Then pValidDate = Now ' Vérifie à la date du jour par défaut
           If CLng("&H" & Mid(sKey, 3, Mid(sKey, 2, 1))) >= CLng(DateValue(pValidDate)) Then
                CheckKey = True
           End If
        Else
            CheckKey = True
        End If
    End If
Exit Function
gestion_erreurs:
CheckKey = False
End Function
 
' Calcul le checksum
Private Function GetCheckSum(sKey As String) As Long
    On Error GoTo gestion_erreurs
    Dim lChecksum As Long
    Dim lCpt As Integer
    lChecksum = 0
    For lCpt = 1 To Len(sKey)
        lChecksum = lChecksum + (GetMult(lCpt) * CLng("&h" & Mid(sKey, lCpt, 1)))
    Next
    GetCheckSum = lChecksum
    Exit Function
gestion_erreurs:
    GetCheckSum = -1
End Function
 
' Génère une clé
' Si pDate est précisée, la clé inclue cette date
Public Function GenerateKey(Optional pDate As Date) As String
Dim LKey As String
Dim lLastNumber As Integer
Dim lCpt As Integer
Dim lModulus As Long
Dim lNextNumber As Long
Dim lCptFirst As Integer
 
Do
    ' Initialise la clé
    LKey = ""
    If pDate = Format("00:00:00") Then
        ' Date non précisée
        ' Premier caractère = A
        LKey = "A"
        ' On commence la génération au deuxième caractère
        lCptFirst = 2
    Else
        ' Date précisée
        ' Premier caractère = D
        LKey = "D"
        ' On ajoute la taille de la date puis la date en Hexa
        LKey = LKey & CStr(Len(CStr(Hex(DateValue(pDate))))) & CStr(Hex(DateValue(pDate)))
        ' On poursuit la génération au caractère suivant la date
        lCptFirst = Len(LKey) + 1
    End If
    ' Jusqu'au caractère 12, génère des chiffres hexa aléatoires
    For lCpt = lCptFirst To 12
        LKey = LKey & CStr(Hex(15 * Rnd))
    Next
    ' Les trois derniers caractères sont calculés pour essayer d'atteindre
    '  un checksum correct (multiple de gModulo)
    For lCpt = 13 To 15
        lModulus = gModulo - (GetCheckSum(LKey) Mod gModulo)
        lNextNumber = lModulus \ GetMult(lCpt)
        If lNextNumber > 15 Then ' pas de chiffre supérieur à 15 (F en hexa)
            lNextNumber = 15
        End If
        LKey = LKey & CStr(Hex(lNextNumber))
    Next
Loop Until (GetCheckSum(LKey) Mod gModulo) = 0  'On boucle tant qu'on a pas trouvé une clé valide
 
GenerateKey = LKey
End Function
 
Public Function Crypter(ByVal pChaine As String)
'---------------------------------------------------------------------------------------
' Procedure : Crypter
' Créée le  : lundi 18 juil 2005 18:51
' Auteur    : Maxence HUBICHE
' Site      : http://mhubiche.developpez.com
' Objet     : Crypter la chaîne en fonction d'une clef et de la méthode
'               de Vigenère
' Adapaté par :
' Thierry GASPERMENT (Arkham46) Cryptage avec valeurs possibles
'---------------------------------------------------------------------------------------
' Le chaine pChaine doit être composée de caractères présents dans gValues
'---------------------------------------------------------------------------------------
 
    Dim sLettres    As String
    Dim lCompteur   As Long
    Dim lLongueur   As Long
    Dim lBoucle     As Long
    Dim lLenValues  As Long
    'Définition de la longueur de la chaîne à crypter et de la chaîne de résultat
    lLongueur = Len(pChaine)
    sLettres = String(lLongueur, Chr(0))
    lLenValues = Len(gValues)
    'Boucler en fonction du nombre de rotations attendues
    For lBoucle = 1 To NBROTATIONSMAX
        'boucler pour chaque caractère de la chaîne initiale
        For lCompteur = 1 To lLongueur
            If InStr(gValues, Mid(pChaine, lCompteur, 1)) <> 0 Then
                Mid(sLettres, lCompteur, 1) = Mid(gValues, (InStr(gValues, Mid(pChaine, lCompteur, 1)) + _
                    (InStr(gValues, Mid(CLEF, (lCompteur Mod Len(CLEF)) + 1, 1)) * lLongueur)) Mod lLenValues + 1)
            Else
                Mid(sLettres, lCompteur, 1) = Mid(pChaine, lCompteur, 1)
            End If
        'recommencer
        Next
        'réaffecter la chaîne à crypter par le résultat trouvé pour pouvoir recommencer une itération
        pChaine = sLettres
    'Nouvelle itération
    Next
    'Renvoyer le résultat final
    Crypter = sLettres
End Function
 
Public Function Decrypter(ByVal pChaine As String)
'---------------------------------------------------------------------------------------
' Procedure : Decrypter
' Créée le  : 25 juin 2005 18:51
' Auteur    : Thierry GASPERMENT
' Site      : http://arkham46.developpez.com
' Objet     : Decrypter la chaîne en fonction d'une clef et de la méthode
'               de Vigenère
'---------------------------------------------------------------------------------------
'
    Dim sLettres    As String
    Dim lCompteur   As Long
    Dim lLongueur   As Long
    Dim lBoucle     As Long
    Dim lLenValues  As Long
    Dim lPosition   As Long
    'Définition de la longueur de la chaîne à crypter et de la chaîne de résultat
    lLongueur = Len(pChaine)
    sLettres = String(lLongueur, Chr(0))
    lLenValues = Len(gValues)
    'Boucler en fonction du nombre de rotations attendues
    For lBoucle = 1 To NBROTATIONSMAX
        'boucler pour chaque caractère de la chaîne initiale
        For lCompteur = 1 To lLongueur
            If InStr(gValues, Mid(pChaine, lCompteur, 1)) <> 0 Then
                lPosition = ((InStr(gValues, Mid(pChaine, lCompteur, 1)) + lLenValues - 1) - ((InStr(gValues, Mid(CLEF, (lCompteur Mod Len(CLEF) + 1), 1)) * lLongueur) Mod lLenValues + 1)) Mod lLenValues + 1
                Mid(sLettres, lCompteur, 1) = Mid(gValues, (lPosition))
            Else
                Mid(sLettres, lCompteur, 1) = Mid(pChaine, lCompteur, 1)
            End If
        'recommencer
        Next
        'réaffecter la chaîne à crypter par le résultat trouvé pour pouvoir recommencer une itération
        pChaine = sLettres
    'Nouvelle itération
    Next
    'Renvoyer le résultat final
    Decrypter = sLettres
End Function

Sauvegarde tout çà dans un nouveau module et tu pourras ensuite générer des clés (limitées ou pas dans le temps), les crypter et bien d'autres choses encore.

Enjoy