IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Défis Discussion :

[OFFICE VBA] Ecrire une fonction de décryptage


Sujet :

Défis

  1. #1
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut [OFFICE VBA] Ecrire une fonction de décryptage
    Bonjour à tous,

    Je vous propose aujourd'hui un petit défi : écrire une fonction de décryptage connaissant la fonction de cryptage.

    Maxence HUBICHE nous livre une fonction de cryptage dans cet article :
    Une petite fonction de cryptage en VBA

    Le défi est d'écrire une fonction Decrypter inverse de la fonction Crypter.

    Pour tester la fonction écrite, il suffit d'enchaîner les deux fonctions.
    On doit retrouver la chaîne de caractères d'origine.
    Par exemple, dans la fenêtre d'exécution :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    ? Decrypter(Crypter("Developpez.com défi décryptage 01234567890"))
    Doit renvoyer le texte : Developpez.com défi décryptage 01234567890

    Ceci est un "défi éclair", poster votre fonction dans cette discussion dès que vous avez la solution.
    Je dévoilerai alors ma fonction à la suite.

    A vos méninges!

  2. #2
    Expert éminent

    Avatar de Maxence HUBICHE
    Homme Profil pro
    Développeur SQLServer/Access
    Inscrit en
    Juin 2002
    Messages
    3 842
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Val d'Oise (Île de France)

    Informations professionnelles :
    Activité : Développeur SQLServer/Access

    Informations forums :
    Inscription : Juin 2002
    Messages : 3 842
    Points : 9 197
    Points
    9 197
    Par défaut
    J'ai le droit de jouer ? Dis ... J'ai le droit ?


  3. #3
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    Citation Envoyé par Maxence HUBICHE Voir le message
    J'ai le droit de jouer ? Dis ... J'ai le droit ?

    si personne d'autre ne trouve

  4. #4
    Expert éminent sénior
    Avatar de Cl@udius
    Homme Profil pro
    Développeur Web
    Inscrit en
    Février 2006
    Messages
    4 878
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 61
    Localisation : France, Haute Garonne (Midi Pyrénées)

    Informations professionnelles :
    Activité : Développeur Web
    Secteur : High Tech - Matériel informatique

    Informations forums :
    Inscription : Février 2006
    Messages : 4 878
    Points : 10 008
    Points
    10 008
    Par défaut
    Et moi le delphiste que je suis, y peux ?

    Ça ce résume à 1 ligne de code dans les 2 boucles imbriquées.

  5. #5
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    Citation Envoyé par Cl@udius Voir le message
    Et moi le delphiste que je suis, y peux ?

    Ça ce résume à 1 ligne de code dans les 2 boucles imbriquées.
    Je ne vais pas faire mon rabat-joie et vous empêcher tous de jouer

  6. #6
    Expert éminent

    Avatar de Maxence HUBICHE
    Homme Profil pro
    Développeur SQLServer/Access
    Inscrit en
    Juin 2002
    Messages
    3 842
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Val d'Oise (Île de France)

    Informations professionnelles :
    Activité : Développeur SQLServer/Access

    Informations forums :
    Inscription : Juin 2002
    Messages : 3 842
    Points : 9 197
    Points
    9 197
    Par défaut
    Bon, allez... j'attends la fin de la semaine pour savoir si je peux gagner une sucette ou pas

  7. #7
    Membre confirmé
    Profil pro
    Inscrit en
    Février 2007
    Messages
    491
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Février 2007
    Messages : 491
    Points : 542
    Points
    542
    Par défaut
    bonjour,

    Voici ma fonction décryptage
    Pas très propre mais bon c 'est pour le jeu

    Code : 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
     
    Function décryptage(ByVal chaîneAD2crypter As String)
    Dim div
    Dim lcompteur As Long
    Dim mot_codé As String
    Dim val_cod
    Dim clef_ch
    Dim asc_mot_codé
    Dim lLongueur As Long
    Dim ofset As Integer
    Dim res
    Dim sLettres    As String
    Dim lBoucle     As Long
     
    Const NBROTATIONSMAX    As Long = 26
    Const CLEF   As String = "nbvfdszé""'(-è_ijhgfcKLKjhgyuilM^+)àçiu-('32azsDRtvBhujkoç_è6tre""zsXWqazerfcx<;:<?"
     
    chaîneAD2crypter = Crypter(chaîneAD2crypter)
    lLongueur = Len(chaîneAD2crypter)
    sLettres = String(lLongueur, Chr(0))
    For lBoucle = 1 To NBROTATIONSMAX
        For lcompteur = 1 To lLongueur
            clef_ch = Asc(Mid(CLEF, (lcompteur Mod Len(CLEF)) + 1, 1)) * lLongueur
            asc_mot_codé = Asc(Mid(chaîneAD2crypter, lcompteur, 1))
            div = clef_ch \ 256
            val_cod = (div * 256) + asc_mot_codé
                If val_cod < clef_ch Then
                    ofset = 256
                        Else: ofset = 0
                End If
            res = val_cod + ofset - clef_ch
        Mid(sLettres, lcompteur, 1) = Chr(res)
        Next lcompteur
          chaîneAD2crypter = sLettres
    Next lBoucle
    décryptage = sLettres
     
    End Function

  8. #8
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut


    Citation Envoyé par patbou Voir le message
    bonjour,

    Voici ma fonction décryptage
    Pas très propre mais bon c 'est pour le jeu

    [...]
    Bien joué !

    Voilà donc ma fonction :
    Code : 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
     
    Public Function Decrypter(ByVal pChaine As String)
    '---------------------------------------------------------------------------------------
    ' Procedure : Decrypter
    ' Créée le  : 25 juin 2008 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 des constantes utiles pour la fonction (Clé et nombre d'itérations de la fonction maximum)
        Const CLEF              As String = "nbvfdszé""'(-è_ijhgfcKLKjhgyuilM^+)àçiu-('32azsDRtvBhujkoç_è6tre""zsXWqazerfcx<;:<?"
        Const NBROTATIONSMAX    As Long = 13
     
        '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))
        '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
                Mid(sLettres, lCompteur, 1) = Chr((Asc(Mid(pChaine, lCompteur, 1)) + 256 - (Asc(Mid(CLEF, (lCompteur Mod Len(CLEF)) + 1, 1)) * lLongueur) Mod 256) Mod 256)
            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
    J'ai un peu galéré pour tout mettre dans une ligne

    Encore bravo à patbou.


  9. #9
    Expert éminent sénior
    Avatar de Cl@udius
    Homme Profil pro
    Développeur Web
    Inscrit en
    Février 2006
    Messages
    4 878
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 61
    Localisation : France, Haute Garonne (Midi Pyrénées)

    Informations professionnelles :
    Activité : Développeur Web
    Secteur : High Tech - Matériel informatique

    Informations forums :
    Inscription : Février 2006
    Messages : 4 878
    Points : 10 008
    Points
    10 008
    Par défaut
    Et voilà pour ma part:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    Function Decrypter(ByVal S As String)
        Dim I As Long, J As Long, L As Long
     
        Decrypter = S
        L = Len(S)
        For I = 1 To NBROTATIONSMAX
            For J = 1 To L
                Mid(Decrypter, J, 1) = Chr(((Asc(Mid(Decrypter, J, 1)) - (Asc(Mid(CLEF, J Mod Len(CLEF) + 1, 1)) * L) Mod 256) + 256) Mod 256)
            Next
        Next
    End Function
    @+

  10. #10
    Expert éminent

    Avatar de Maxence HUBICHE
    Homme Profil pro
    Développeur SQLServer/Access
    Inscrit en
    Juin 2002
    Messages
    3 842
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Val d'Oise (Île de France)

    Informations professionnelles :
    Activité : Développeur SQLServer/Access

    Informations forums :
    Inscription : Juin 2002
    Messages : 3 842
    Points : 9 197
    Points
    9 197
    Par défaut


    bon, ben ... tant pis alors... avec trois réponses, je m'incline
    Pour ma part, j'avais la même solution que cl@udius, mais avec la totalité du code autour et après avoir sorti les constantes de la procédure crypter pour en étendre la portée au module...
    vàlà vàlà...


  11. #11
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    bravo et merci à vous

    maintenant on sait décrypter la fonction de maxence

  12. #12
    Membre régulier
    Profil pro
    Inscrit en
    Août 2007
    Messages
    103
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Août 2007
    Messages : 103
    Points : 91
    Points
    91
    Par défaut
    Pensez aussi que vous risquez deux choses qui pourraient faire planter votre programme
    1. L'addition des 2 codes ASCII risque de dépasser la valeur 255, ce qui n'est pas acceptable, les valeurs de la table ASCII étant comprises entre 0 et 255. un moyen de passer outre cette limite sera d'utiliser le modulo (reste d'une division entière) par 256
    2. La longueur de la chaîne à crypter pourrait être plus longue que votre clé, ce qui implique de retourner au début de la clé à chaque fois qu'on est arrivé à la fin. Encore une fois, le modulo par la longueur de la chaîne devrait nous permettre de nous en sortir.
    Et aussi une troisième: Les codes des caractères inférieurs à 32 ne sont pas toujours utilisables sous MS-Office.

    Par conséquent, un valeur cryptée à l'aide de la méthode de maxence ne peut pas être stockée dans une cellule pour être décryptée plus tard...

    Mon défit à moi sera peut être de limiter l'alphabet utilisable aux caractères imprimables entre 32 et 255 dans la table ascii.

    La seule chose, c'est comment faire ?... C'est mon défit... Je reviendrai que quand je saurais faire... Au revoir pour un bout de temps... ;D Content de vous avoir connu ...

  13. #13
    Responsable Access

    Avatar de Arkham46
    Profil pro
    Inscrit en
    Septembre 2003
    Messages
    5 865
    Détails du profil
    Informations personnelles :
    Localisation : France, Loiret (Centre)

    Informations forums :
    Inscription : Septembre 2003
    Messages : 5 865
    Points : 14 522
    Points
    14 522
    Par défaut
    Bjr,

    Citation Envoyé par JMPS.VBA Voir le message
    Mon défit à moi sera peut être de limiter l'alphabet utilisable aux caractères imprimables entre 32 et 255 dans la table ascii.
    Voir ici :
    http://www.developpez.net/forums/d36...ence-cryptees/
    On peut définir les caractères utilisables.

  14. #14
    Membre régulier
    Profil pro
    Inscrit en
    Août 2007
    Messages
    103
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Août 2007
    Messages : 103
    Points : 91
    Points
    91
    Par défaut
    Voir ici
    C'est pas drôle !

    Mais bon.... je suis faible.... alors j'y vais...

    Mais je maintien que c'est pas drôle !

    ___________________
    PS : Merci quand même

  15. #15
    Membre régulier
    Profil pro
    Inscrit en
    Août 2007
    Messages
    103
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Août 2007
    Messages : 103
    Points : 91
    Points
    91
    Par défaut
    Mon soucis c'est que je peux le faire avec une fonction de feuille de calcul, mais le code de Arkham46 est trop imbriqué pour mes petits neurones. je ne le comprends pas à ces heures tardives (même le matin j'aurais du mal de toute façon).
    Un petit coup de main je veux bien.

    dans une feuille de calcul je pose :

    Colonne A = CODE(Caractère Clair) 'Obligatoirement >=32 et <=255
    Colonne B = CODE(Caractère de la Clef) 'Obligatoirement >=32 et <=255
    Colonne C = A1 + B1

    Pour générer un caractère crypté compris entre 32 et 255:
    Colonne D = MOD(C1;224)+32

    Pour retrouver le caractère clair
    Colonne E =MOD(((D1+224)-(MOD(B1;224)+32))-32;224)+32


    Donc le code VBA devrait être : je ne le met pas entre balises de code exprès pour conserver la couleur des parenthèses et essayer de comprendre l'erreur dans les imbrications ....

    Pour coder :
    ___________________________
    Mid(sLettres, lCompteur, 1) =

    Chr(((Asc(Mid(pChaine, lCompteur, 1)) + (Asc(Mid(CLEF, (lCompteur Mod Len(CLEF)) + 1, 1)) * lLongueur)) Mod 224) + 32)
    ___________________________
    OUI, Ok, Ça fonctionne


    Pour décoder :
    ___________________________
    Mid(sLettres, lCompteur, 1) =

    Chr(((((Asc(Mid(pChaine, lCompteur, 1)) + 224)- ((Asc(Mid(CLEF, (lCompteur Mod Len(CLEF)) + 1, 1)) * lLongueur) Mod 224)+32)-32) Mod 224)+32)
    ___________________________
    NON, Ça ne fonctionne pas ....
    Ça ne décode pas... Ça déconne plutôt... (Jeux de mots si vous permettez)

    23h00 bientôt, je vais me coucher, demain travail...

    _______________________________
    NB j'ai testé le code du lien proposé par Arkham46 , mais ça ne me convient pas. 1) j'ai pas tout compris (ou rien compris), 2) je ne veux pas de caractères non imprimables (code ascii entre 1 et 31) car ils génèrent des erreurs au décryptage dans les cellules ou les contrôles de formulaires.
    Le pire c'est que j'ai pas besoin de tout ça, c'est juste pour du codage en VBA...

  16. #16
    Membre régulier
    Profil pro
    Inscrit en
    Août 2007
    Messages
    103
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Août 2007
    Messages : 103
    Points : 91
    Points
    91
    Par défaut
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    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 : 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
    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 ?

  17. #17
    Membre régulier
    Profil pro
    Inscrit en
    Août 2007
    Messages
    103
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Août 2007
    Messages : 103
    Points : 91
    Points
    91
    Par défaut
    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 : 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
    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ÑtfE‹›–Ð~¬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

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. [VB6]Ecrire une fonction dans ma feuille Excel
    Par ToxiK dans le forum VB 6 et antérieur
    Réponses: 8
    Dernier message: 08/06/2006, 21h04
  2. Réponses: 1
    Dernier message: 07/06/2006, 19h18
  3. [VBA]Atteindre une fonction dans un xla
    Par boosty dans le forum Macros et VBA Excel
    Réponses: 9
    Dernier message: 27/01/2006, 14h13
  4. Réponses: 15
    Dernier message: 15/12/2005, 15h36
  5. [VBA] Executer une fonction en passant son nom en argument
    Par David Guyon dans le forum Access
    Réponses: 4
    Dernier message: 05/10/2005, 20h56

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo