Ci-dessous un exemple de code VBA pour générer des clés de licence.
Un premier module pour générer et vérifier la validité d'une clé.
Un deuxième module pour crypter/décrypter la clé afin de sécuriser un peu plus.
Premier module : ModKeyGen
La clé générée est en hexa (caractères 0 à 9 et A à F) et de 15 caractères de long.
Personnalisez l'agorithme de génération de clé en modifiant les valeurs de la fonction GetMult
Le multiplicateur 15 doit être égal à 1.
Laissez une valeur assez élevé au multiplicateur 14 (supérieur au multiplicateur 13).
Vous pouvez également modifier la valeur de gModulo qui doit être inférieur à la somme des multiplicateur * 15.
Vous pouvez générer une clé avec la fonction GenerateKey.
(pour déployer votre application, retirez cette fonction (conservez la quelque part quand même...) et créez un mde)
Le paramètre pDate est optionnel, il permet de définir à quel date la clé de licence expire.
Vous pouvez vérifier une clé avec la fonction CheckKey.
Le paramètre sKey est la clé à tester.
Le paramètre pValidDate est la date à laquelle on souhaite tester la validité de la clé (date du jour si paramètre omis)
Exemples :
GenerateKey(now+60) renvoie une clé D49F70D08E6AF45 valide 60 jours
GenerateKey() renvoie une clé A57274982EA8FEB sans limitation de temps
CheckKey("D49F70D08E6AF45",Now) renvoit Vrai car la clé est valide aujourd'hui.
CheckKey("D49F70D08E6AF45",Now+90) renvoit Faux car les 60 jours sont dépassés.
CheckKey("A57274982EA8FEB",Now+90) renvoit Vrai car la clé toujours valide.
Deuxième module : ModCryptage
Programmé à partir de la fonction de cryptage de Maxence :
http://mhubiche.developpez.com
La fonction Crypter crypte une chaine de caractères.
La fonction Decrypter decrypte une chaine de caractères.
Personnalisez votre cryptage en modifiant la CLE et le nombre d'itérations NBROTATIONSMAX.
La constante gValues contient les caractères qui vont composer la chaine cryptée. Les caractères qui n'apparaissent pas dans cette constante ne seront pas cryptés.
Exemples :
crypter("HELLO =abc 123456") renvoie JLUB7 =abc 39TZO0
decrypter("JLUB7 =abc 39TZO0") renvoie HELLO =abc 123456
On peut alors combiner la génération de clé et le cryptage
Crypter(GenerateKey()) renvoit W48K455QDMYVAL9
CheckKey(Decrypter("W48K455QDMYVAL9")) renvoit Vrai
----> Ces codes VBA sont donnés pour exemple et comme base de travail
Code modKeyGen : 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 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 ' 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
Code modCryptage : 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 Option Explicit Option Private Module ' 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" 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
Partager