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
|
Const MASQUE As String = "933441295391989330356725734543502463" 'Masque de la feuille à trou de Freissner
Const Itérations As Variant = 223 'Nombre maximum d'itérations majorB-1
Const Minor As Variant = 32 'Code du caractère ascii le plus bas dans la table
Const Major As Variant = 255 'Code du cactère ascii le plus haut dans la table
Dim CLEF As String 'Clef CryptageVigenère en variable pour contrôle de la plage des caratères
Sub MAIN()
Dim TEXTE1 As String
Dim TEXTE2 As String
TEXTE1 = InputBox("Taper votre texte ci-dessous :")
TEXTE2 = CRYPTAGE(TEXTE1, True)
MsgBox "Votre texte décrypté : " & Chr$(13) & TEXTE1 & Chr$(13) & Chr$(13) & "Cryptage : " & Chr$(13) & TEXTE2
TEXTE1 = CRYPTAGE(TEXTE2, False)
MsgBox "Votre texte crypté : " & Chr$(13) & TEXTE2 & Chr$(13) & Chr$(13) & "Décryptage : " & Chr$(13) & TEXTE1
End Sub
Function CRYPTAGE(ByVal Chaîne As String, ByVal Sens As Boolean)
'Controle Minor/Major
If Minor + Minor - 1 > Major Then MsgBox "Minor+Minor-1 > Major : Minor est trop élevé ou Major est trop bas"
If Major - (256 - Major) < Minor Then MsgBox "Major - (256 - Major) < Minor : Major est trop bas ou Minor est trop élevé"
'Clef pour CRyptage de Vigenère : Contrôle de la table ASCII utilisée pour la clef (Borne Minor et Major)
CLEF = "µÂ,^P§f>}¿!/Ð##øcuÝj]e+0¦Ùåå 擄5ZJîñ
r3ß/-9ÑtfEÐ~¬há"
CLEF = Formatage(CLEF, True)
Select Case Sens
Case True: CRYPTAGE = CryptageFleissner(CryptageVigenère(Formatage(Chaîne, Sens), Sens), Sens)
Case False: CRYPTAGE = Formatage(CryptageVigenère(CryptageFleissner(Chaîne, Sens), Sens), Sens)
End Select
End Function
Public Function CryptageVigenère(ByVal Chaîne As String, ByVal Sens As Boolean)
Dim Traitement As Variant 'Chaîne en cours de Traitement codage/décodage
Dim Position As Variant ' Position en cours de Traitement
Dim LgChaîne As Variant 'Nombre de caractères dans la chaîne à crypter
Dim LgClef As Variant 'Nombre de caractères dans la clef
Dim CarChaîne As Variant 'caractère sélectionné dans la chaîne à crypter/décrypter
Dim CarClef As Variant 'caractère sélectioné dans la clef
Dim Itération As Variant 'Compteur d'itération
Dim MajorB As Variant 'Redéfinit Major pour la plage en fonction de Minor
'Chaîne = Texte à crypter ou à décrypter
'Sens = True Crypter ou False Décrypter
'Définition de la LgChaîne de la chaîne à crypter et de la chaîne de résultat
MajorB = 1 + Major - Minor
LgClef = Len(CLEF)
LgChaîne = Len(Chaîne)
Traitement = String(LgChaîne, Chr(0))
'Boucler en fonction du nombre de rotations attendues
For Itération = 1 To Itérations
For Position = 1 To LgChaîne
'Recherche et met en phase les caractères en cours de la chaîne et de la clef
CarChaîne = Asc(Mid(Chaîne, Position, 1))
CarClef = Asc(Mid(CLEF, (Position - (LgClef * Int(Position / LgClef))) + 1, 1))
'Traitement de la chaîne en Cryptage/Déctyptage : substitution de caractères
Select Case Sens
Case True: Mid(Traitement, Position, 1) = Chr(((CarChaîne + CarClef) - MajorB * Int((CarChaîne + CarClef) / MajorB)) + Minor)
Case False: Mid(Traitement, Position, 1) = Chr((((CarChaîne + MajorB) - (((CarClef - MajorB * Int(CarClef / MajorB)) + Minor)) - Minor) - MajorB * Int(((CarChaîne + MajorB) - (((CarClef - MajorB * Int(CarClef / MajorB)) + Minor)) - Minor) / MajorB)) + Minor)
End Select
Next
'réaffecter la chaîne à crypter par le résultat trouvé pour pouvoir recommencer une itération
Chaîne = Traitement
'Nouvelle itération
Next
'Renvoyer le résultat final
CryptageVigenère = Traitement
End Function
Function CryptageFleissner(ByVal Chaîne As String, ByVal Sens As Boolean)
Dim Traitement As Variant 'Chaîne en cours de Traitement
Dim Position As Variant ' Position en cours de Traitement
Dim LgChaîne As Variant 'Nombre de caractères dans la chaîne à crypter
Dim LgMasque As Variant 'Nombre de caractères dans la chaîne à crypter
Dim Itération As Variant 'Compteur d'itération
Dim CarChaîne As Variant
Dim CarMasque As Variant
'Chaîne = Texte à crypter ou à décrypter
'Sens = True Crypter ou False Décrypter
'Définition de la LgChaîne de la chaîne à crypter et de la chaîne de résultat
LgChaîne = Len(Chaîne)
LgMasque = Len(MASQUE)
'Supprime des caractères en début de chaîne en mode Décodage (Confusion)
If Sens = False Then Chaîne = Mid(Chaîne, Mid(MASQUE, 1, 1) + 1)
For Position = 1 To LgChaîne
CarChaîne = Mid(Chaîne, Position, 1)
Select Case Sens
Case True
CarMasque = Mid(MASQUE, (Position Mod LgMasque + 1), 1)
Traitement = Traitement & CarChaîne & CaractèresAléatoires(CarMasque)
Case False
Traitement = Traitement & CarChaîne
Position = Position + Mid(MASQUE, (Len(Traitement) Mod LgMasque + 1), 1)
End Select
Next
'Ajoute des caractères en début de chaîne en mode Codage (Confusion)
If Sens = True Then Traitement = CaractèresAléatoires(Mid(MASQUE, 1, 1)) & Traitement
CryptageFleissner = Traitement
End Function
Function CaractèresAléatoires(ByVal Nombre As Long) As String
Dim Répétition As Double
Dim TempString As String
For Répétition = 0 To Nombre - 1
TempString = TempString & Chr$(Int((Major - Minor + 1) * Rnd + Minor))
Next
CaractèresAléatoires = TempString
End Function
Function Formatage(ByVal Chaîne As String, ByVal Sens As Boolean)
'Remplace les caractères en dehors de la borne par des caractères dans la plage autorisée
Dim Itération As Double
Dim CodeSuite1 As Integer 'Code suite en position 1 remplaçant le caractère proscrit
Dim CodeSuite2 As Integer 'Code suite en position 2 remplaçant le caractère proscrit
Dim CodeSuite4 As Integer 'Code suite en position 4 remplaçant le caractère proscrit
Dim CarSuite1 As String 'Caractère suite en position 1 remplaçant le caractère proscrit
Dim CarSuite2 As String 'Caractère suite en position 2 remplaçant le caractère proscrit
Dim CarSuite4 As String 'Caractère suite en position 4 remplaçant le caractère proscrit
'Définition des variables
CodeSuite1 = Minor
CodeSuite2 = Int((Minor + Major) / 2)
CodeSuite4 = Major
CarSuite1 = Chr(CodeSuite1)
CarSuite2 = Chr(CodeSuite2)
CarSuite4 = Chr(CodeSuite4)
Do While Itération < Len(Chaîne)
Itération = Itération + 1
Select Case Sens
Case True
'Substitution des caractère sproscrits par une suite de caractères connus
'Borne Inférieur
If Asc(Mid(Chaîne, Itération, 1)) < Minor Then
Chaîne = Mid(Chaîne, 1, Itération - 1) & CarSuite1 & CarSuite2 & Chr(Asc(Mid(Chaîne, Itération, 1)) + Minor) & CarSuite4 & Mid(Chaîne, Itération + 1)
Itération = Itération + 3
End If
'Borne Supérieur
If Asc(Mid(Chaîne, Itération, 1)) > Major Then
Chaîne = Mid(Chaîne, 1, Itération - 1) & CarSuite4 & CarSuite1 & Chr(Asc(Mid(Chaîne, Itération, 1)) - (255 - Major)) & CarSuite2 & Mid(Chaîne, Itération + 1)
Itération = Itération + 3
End If
Case False
'Substitution d'une suite de caractères connus par des caractères proscrits
If Itération + 3 > Len(Chaîne) Then Exit Do
'Borne Inférieur
If Asc(Mid(Chaîne, Itération, 1)) + Asc(Mid(Chaîne, Itération + 1, 1)) + Asc(Mid(Chaîne, Itération + 3, 1)) = (CodeSuite1 + CodeSuite2 + CodeSuite4) And _
(Asc(Mid(Chaîne, Itération + 2, 1)) - Minor >= 0 And Asc(Mid(Chaîne, Itération + 2, 1)) - Minor < Minor) Then
Chaîne = Mid(Chaîne, 1, Itération - 1) & Chr(Asc(Mid(Chaîne, Itération + 2, 1)) - Minor) & Mid(Chaîne, Itération + 4)
End If
'Borne supérieur
If Asc(Mid(Chaîne, Itération, 1)) + Asc(Mid(Chaîne, Itération + 1, 1)) + Asc(Mid(Chaîne, Itération + 3, 1)) = (CodeSuite4 + CodeSuite1 + CodeSuite2) And _
(Asc(Mid(Chaîne, Itération + 2, 1)) + (255 - Major) >= Major And Asc(Mid(Chaîne, Itération + 2, 1)) + (255 - Major) < 256) Then
Chaîne = Mid(Chaîne, 1, Itération - 1) & Chr(Asc(Mid(Chaîne, Itération + 2, 1)) + (255 - Major)) & Mid(Chaîne, Itération + 4)
End If
End Select
Loop
Formatage = Chaîne
End Function |
Partager