Option Explicit
' 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
Private Sub CommandButton1_Click()
Dim variable As String
On Error GoTo Errorhandler
variable = "B7SVVDK"
Range("B600").Value = "=A600"
[A600].Value = "=crypter(" & inputbox("écrivez votre mot de passe en majuscules et entre guillemets") & ")"
If Range("B600").Value = variable Then MsgBox ("mot de passe bon")
If [B600].Value <> "B7SVVDK" Then
MsgBox ("mot de passe faux")
[A600].Delete
Exit Sub
End If
[A600].Delete
 Exit Sub
Errorhandler:
 MsgBox ("il y a eu erreur veuillez recommencer")
 [A600].Delete
End Sub