[OFFICE VBA] Ecrire une fonction de décryptage - Page 2

JMPS.VBA · 22/11/2008, 19h49

Code :

Const CLEF As String = "azerty uiop"
Const Itérations    As Variant = 1 'Nombre maximum d'itérations 256
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

Code :

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 Mod LgClef) + 1, 1)) '* LgChaîne
            
            Select Case Sens
            Case True: Mid(Traitement, Position, 1) = Chr(((CarChaîne + CarClef) Mod MajorB) + Minor)
            Case False: Mid(Traitement, Position, 1) = Chr((((CarChaîne + MajorB) - ((CarClef Mod MajorB) + Minor) - Minor) Mod MajorB) + Minor)
            Case Else: 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

Ça ne marche très bien que pour une seule itération.
après ça m'invente des caractère en dehors de la plage.
moi pas comprendre pourquoi ...
j'ai pensé que le type de données n'était pas adapté, j'ai tout passé en variant... mais non ... donc pas comprendre... et pourtant moi chercher beaucoup, lire beaucoup, etc... mais non moi pas comprendre pourquoi ça pas marcher après itération 1 ?

JMPS.VBA · 23/11/2008, 20h22

J'arrête sur ce sujet.
J'ai trouvé ma solution pour crypter et décrypter le texte de cellules ou de contrôles de formulaires ou même des docs words... en supprimant du cryptage les codes de retour chariot, tabulation et autres (ceux dont la code ascii est inférieur à 32), et en les retrouvant après le décryptage afin de conserver la mise en page d'avant cryptage...
Au cryptage de vigenère, j'ajoute une confusion supplémentaire avec le cryptage de Freissner (seul, c'est très facile à casser, donc très peu d'intérêt)

La macro principale c'est SUB MAIN().

Code :

 
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

		Forum des développeurs > Hardware, Systèmes et Logiciels > Microsoft Office > Défis
[OFFICE VBA] Ecrire une fonction de décryptage

Outils de la discussion
Afficher une version imprimable Envoyer un lien vers cette page par email