Ce chiffrement est une variante légèrement compliqué d’un carré de Polybe

1. On crée une première clé une matrice de 5×5 contenant un alphabet ordonnée ou désordonnée, le W étant volontairement omis (dans notre cas Azerty..etc)
2. On défini une deuxième clé de 25 caractère maximum (biscotte) que l’on chiffre avec la matrice précédemment rempli
3. Au message chiffré, on additionne lettre par lettre la clé 2  pour obtenir notre message chiffré

1 2 3 4 5
1 a z e r t
2 y u i o p
3 q s d f g
4 h j k l m
5 x c v b n

test :
message clair :  « le chiffre des nihilistes »
cle 2 : visualbasic

Message clair       l  e  c  h  i   f  f  r  e d  e  s  n  i  h  i  l  i  s  t  e  s
Lettres chiffrées     44 13 52 41 23 34 34 14 13 33 13 32 55 23 41 23 44 23 32 15 13 32
Mot de passe (répété) 53 23 32 22 11 44 54 11 32 23 52 53 23 32 22 11 44 54 11 32 23 52
Message chiffré final 97 36 84 63 34 78 88 25 45 56 65 85 78 55 63 34 88 77 43 47 36 84

A savoir  que chaque lettre doit avoir 2 chiffre, on soustrait donc 100 aux sommes comprises entre 100 et 110.
51+55 est donc égale à 06.

Télécharger la source VB6

Dim choix As Boolean 'on crypte ou decrypte
Dim tcle(4, 4) As String 'matrice cle1
Dim tabcle2() As Integer 'tableau cle2
Dim tabcf() As String 'tableau message chiffré peut contenir des nombre ou des lettres

Private Sub verification(choix)
If Len(cle1.Text) <> 25 Then MsgBox "erreur, la cle 1 doit avoir 25 caractere", vbCritical, "erreur cle 1"
If Len(cle2.Text) > 25 Then MsgBox "erreur, la cle 2 doit avoir moins de 25 caractere", vbCritical, "erreur cle 2"
Select Case choix '(0 on decrypte, 1 on crypte)
    Case 0
        If messcrypt.Text = "" Then MsgBox "erreur, il n'y a rien a dechiffré ", vbCritical, "message=vide": mess.Text = ""

    Case 1
        If mess.Text = "" Then MsgBox "erreur, il n'y a rien a chiffré ", vbCritical, "message=vide": messcrypt.Text = ""
End Select
End Sub

Private Sub chiffre_Click()
Dim car As String

verification (1) 'verifie les regles pour le cryptage
tabc1.Text = ""
tabc2.Text = ""
messcrypt.Text = ""

'on ne traite pas les espaces
Dim message As String: message = Replace(mess.Text, " ", "")
'determine la longueur du message et de la cle 2
Dim lngmess As Integer: lngmess = Trim(Len(message))
Dim lngcle2 As Integer: lngcle2 = Trim(Len(cle2.Text))

'mise en condition de la premiere clé
tabc1.Text = traitecle1(cle1.Text)

'mise en condition de la seconde clé
'par rapport a la longeur du texte a crypter
tabc2.Text = Left(traitecle2(cle2.Text, lngmess), (lngcle2 * 3))

'//////////////on chiffre

ReDim tabcf(lngmess)
'chaque lettre est remplacer par les coordonnées i j de la matrice
For i = 1 To lngmess
    car = UCase(Mid(message, i, 1))
    tabcf(i - 1) = findchiffre(car)
Next i

'on addtionne ensuite le message chiffré avec le tableau
'chiffré de la 2ieme cle lettre par lettre (chiffré)
'pour chaque cas , si le resultat est superieur a 100 on enleve 100
Dim res As Integer
For i = 0 To UBound(tabcf) - 1
    res = CInt(tabcf(i)) + CInt(tabcle2(i))
    If res >= 100 Then res = res - 100
    If Len(LTrim(res)) = 1 Then
         messcrypt.Text = messcrypt.Text & "0" & res & " "
    Else
         messcrypt.Text = messcrypt.Text & res & " "
    End If
Next i

End Sub
Private Function traitecle1(cle1 As String) As String
'mise en condition de la premiere clé
'insere dans une matrice la cle 1
Dim p As Integer: p = 1
Dim sortie As String: sortie = ""

For i = 0 To 4
    For j = 0 To 4
        car = UCase(Mid(cle1, p, 1))
        tcle(i, j) = car
        sortie = sortie & car & "|" 'pour l'affichage sur la form
        p = p + 1
        Next j
    sortie = sortie & vbCrLf 'pour l'affichage sur la form
Next i

traitecle1 = sortie

End Function
Private Function traitecle2(cle2 As String, lng As Integer) As String
'mise en condition de la deuxieme clé
'chiffre la clé 2 avec la matrice de la cle1
'et la prolonge en la repetant jusqu'a atteindre la
'longueur du message a chiffré
ReDim tabcle2(lng)
Dim lngc2 As Integer: lngc2 = Len(cle2)
Dim sortie As String
Dim car As String

For i = 0 To UBound(tabcle2) - 1
    car = UCase(Mid(cle2, j + 1, 1))
    tabcle2(i) = findchiffre(car)
    j = j + 1
    If j = lngc2 Then j = 0
    sortie = sortie & " " & tabcle2(i)
Next i

traitecle2 = sortie
End Function
Private Sub dechiffre_Click()

verification (0) 'verifie les regles du decryptage
tabc1.Text = ""
tabc2.Text = ""
mess.Text = ""

'on ne traite pas les espaces
Dim message As String: message = messcrypt.Text
'determine la longueur du message et de la cle 2
Dim lngmess As Integer: lngmess = Trim(Len(message)) / 3 '2 chiffres vont donnée 1 caractere + 1 pour l'espace entre 2 chiffres
Dim lngcle2 As Integer: lngcle2 = Trim(Len(cle2.Text))

'mise en condition de la premiere clé
tabc1.Text = traitecle1(cle1.Text)

'mise en condition de la seconde clé
'par rapport a la longeur du texte a decrypter
tabc2.Text = Left(traitecle2(cle2.Text, lngmess), (lngcle2 * 3))

'//////////////on dechiffre
'ReDim tabcf(lngmess)
tabcf = Split(message, " ")

'pour dechiffrer il suffit de soustraire la chaine de la clé 2 a la chaine du message crypter
'ne pas oublier de rajouter 100 si le nombre commence par 0

Dim res As Integer
For i = 0 To UBound(tabcf) - 1
If Left(tabcf(i), 1) = 0 Then tabcf(i) = CInt(tabcf(i)) + 100
    res = tabcf(i) - tabcle2(i): If res = 0 Then Exit Sub
    'il nous suffit maintenant de retrouver la lettre correspondante au nombre
    y = CInt(Left(res, 1)) - 1
    x = CInt(Right(res, 1)) - 1
    mess.Text = mess.Text & tcle(y, x)
Next i

End Sub

'retourne les coordonnées ij d'une lettre sous forme d'un chiffre
Private Function findchiffre(car As String) As Integer
For i = 0 To 4
    For j = 0 To 4
       If tcle(i, j) = car Then findchiffre = (i + 1) & (j + 1)
    Next j
Next i
End Function

Private Sub Form_Load()
choix = 1
End Sub