Générer des clés de licence cryptées

[Arkham46]

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é D499970BCB16F47 valide 60 jours
GenerateKey() renvoie une clé GDC6ED1E58C1A07 sans limitation de temps

CheckKey("D499970BCB16F47",Now) renvoit Vrai car la clé est valide aujourd'hui.
CheckKey("D499970BCB16F47",Now+90) renvoit Faux car les 60 jours sont dépassés.
CheckKey("GDC6ED1E58C1A07 ",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

 
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 Resume Next
    Dim lChecksum As Long
    Dim lCpt As Integer
    lChecksum = 0
    For lCpt = 1 To 15
        lChecksum = lChecksum + (GetMult(lCpt) * CLng("&h" & Mid(sKey, lCpt, 1)))
    Next
    GetCheckSum = lChecksum
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 = G
        lKey = "G"
        ' 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
 

 
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
 

[philben]

EXCELLENT

Bon, je sais que ça ne va pas vous faire couler une larme d'émotion, mais ça me faisait plaisir de vous le dire !

Philippe