Data commit
This commit is contained in:
Ingy döt Net
parent
7387c8f97b
commit
cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
207
Task/Playfair-cipher/VBA/playfair-cipher.vba
Normal file
207
Task/Playfair-cipher/VBA/playfair-cipher.vba
Normal file
|
|
@ -0,0 +1,207 @@
|
|||
Option Explicit
|
||||
|
||||
Private Type Adress
|
||||
Row As Integer
|
||||
Column As Integer
|
||||
End Type
|
||||
|
||||
Private myTable() As String
|
||||
|
||||
Sub Main()
|
||||
Dim keyw As String, boolQ As Boolean, text As String, test As Long
|
||||
Dim res As String
|
||||
keyw = InputBox("Enter your keyword : ", "KeyWord", "Playfair example")
|
||||
If keyw = "" Then GoTo ErrorHand
|
||||
Debug.Print "Enter your keyword : " & keyw
|
||||
boolQ = MsgBox("Ignore Q when buiding table y/n : ", vbYesNo) = vbYes
|
||||
Debug.Print "Ignore Q when buiding table y/n : " & IIf(boolQ, "Y", "N")
|
||||
Debug.Print ""
|
||||
Debug.Print "Table : "
|
||||
myTable = CreateTable(keyw, boolQ)
|
||||
On Error GoTo ErrorHand
|
||||
test = UBound(myTable)
|
||||
On Error GoTo 0
|
||||
text = InputBox("Enter your text", "Encode", "hide the gold in the TRRE stump")
|
||||
If text = "" Then GoTo ErrorHand
|
||||
Debug.Print ""
|
||||
Debug.Print "Text to encode : " & text
|
||||
Debug.Print "-------------------------------------------------"
|
||||
res = Encode(text)
|
||||
Debug.Print "Encoded text is : " & res
|
||||
res = Decode(res)
|
||||
Debug.Print "Decoded text is : " & res
|
||||
text = InputBox("Enter your text", "Encode", "hide the gold in the TREE stump")
|
||||
If text = "" Then GoTo ErrorHand
|
||||
Debug.Print ""
|
||||
Debug.Print "Text to encode : " & text
|
||||
Debug.Print "-------------------------------------------------"
|
||||
res = Encode(text)
|
||||
Debug.Print "Encoded text is : " & res
|
||||
res = Decode(res)
|
||||
Debug.Print "Decoded text is : " & res
|
||||
Exit Sub
|
||||
ErrorHand:
|
||||
Debug.Print "error"
|
||||
End Sub
|
||||
|
||||
Private Function CreateTable(strKeyword As String, Q As Boolean) As String()
|
||||
Dim r As Integer, c As Integer, temp(1 To 5, 1 To 5) As String, t, cpt As Integer
|
||||
Dim strT As String, coll As New Collection
|
||||
Dim s As String
|
||||
|
||||
strKeyword = UCase(Replace(strKeyword, " ", ""))
|
||||
If Q Then
|
||||
If InStr(strKeyword, "J") > 0 Then
|
||||
Debug.Print "Your keyword isn't available with your choice : Not Q (==> J) !"
|
||||
Exit Function
|
||||
End If
|
||||
Else
|
||||
If InStr(strKeyword, "Q") > 0 Then
|
||||
Debug.Print "Your keyword isn't available with your choice : Q (==> Not J) !"
|
||||
Exit Function
|
||||
End If
|
||||
End If
|
||||
strT = IIf(Not Q, "ABCDEFGHIKLMNOPQRSTUVWXYZ", "ABCDEFGHIJKLMNOPRSTUVWXYZ")
|
||||
t = Split(StrConv(strKeyword, vbUnicode), Chr(0))
|
||||
For c = LBound(t) To UBound(t) - 1
|
||||
strT = Replace(strT, t(c), "")
|
||||
On Error Resume Next
|
||||
coll.Add t(c), t(c)
|
||||
On Error GoTo 0
|
||||
Next
|
||||
strKeyword = vbNullString
|
||||
For c = 1 To coll.Count
|
||||
strKeyword = strKeyword & coll(c)
|
||||
Next
|
||||
t = Split(StrConv(strKeyword & strT, vbUnicode), Chr(0))
|
||||
c = 1: r = 1
|
||||
For cpt = LBound(t) To UBound(t) - 1
|
||||
temp(r, c) = t(cpt)
|
||||
s = s & " " & t(cpt)
|
||||
c = c + 1
|
||||
If c = 6 Then c = 1: r = r + 1: Debug.Print " " & s: s = ""
|
||||
Next
|
||||
CreateTable = temp
|
||||
End Function
|
||||
|
||||
Private Function Encode(s As String) As String
|
||||
Dim i&, t() As String, cpt&
|
||||
s = UCase(Replace(s, " ", ""))
|
||||
'insert "X"
|
||||
For i = 1 To Len(s) - 1
|
||||
If Mid(s, i, 1) = Mid(s, i + 1, 1) Then s = Left(s, i) & "X" & Right(s, Len(s) - i)
|
||||
Next
|
||||
'Do the pairs
|
||||
For i = 1 To Len(s) Step 2
|
||||
ReDim Preserve t(cpt)
|
||||
t(cpt) = Mid(s, i, 2)
|
||||
cpt = cpt + 1
|
||||
Next i
|
||||
If Len(t(UBound(t))) = 1 Then t(UBound(t)) = t(UBound(t)) & "X"
|
||||
Debug.Print "[the pairs : " & Join(t, " ") & "]"
|
||||
'swap the pairs
|
||||
For i = LBound(t) To UBound(t)
|
||||
t(i) = SwapPairsEncoding(t(i))
|
||||
Next
|
||||
Encode = Join(t, " ")
|
||||
End Function
|
||||
|
||||
Private Function SwapPairsEncoding(s As String) As String
|
||||
Dim r As Integer, c As Integer, d1 As String, d2 As String, Flag As Boolean
|
||||
Dim addD1 As Adress, addD2 As Adress, resD1 As Adress, resD2 As Adress
|
||||
d1 = Left(s, 1): d2 = Right(s, 1)
|
||||
For r = 1 To 5
|
||||
For c = 1 To 5
|
||||
If d1 = myTable(r, c) Then addD1.Row = r: addD1.Column = c
|
||||
If d2 = myTable(r, c) Then addD2.Row = r: addD2.Column = c
|
||||
If addD1.Row <> 0 And addD2.Row <> 0 Then Flag = True: Exit For
|
||||
Next
|
||||
If Flag Then Exit For
|
||||
Next
|
||||
Select Case True
|
||||
Case addD1.Row = addD2.Row And addD1.Column <> addD2.Column
|
||||
'same row, different columns
|
||||
resD1.Column = IIf(addD1.Column + 1 = 6, 1, addD1.Column + 1)
|
||||
resD2.Column = IIf(addD2.Column + 1 = 6, 1, addD2.Column + 1)
|
||||
SwapPairsEncoding = myTable(addD1.Row, resD1.Column) & myTable(addD2.Row, resD2.Column)
|
||||
Case addD1.Row <> addD2.Row And addD1.Column = addD2.Column
|
||||
'same columns, different rows
|
||||
resD1.Row = IIf(addD1.Row + 1 = 6, 1, addD1.Row + 1)
|
||||
resD2.Row = IIf(addD2.Row + 1 = 6, 1, addD2.Row + 1)
|
||||
SwapPairsEncoding = myTable(resD1.Row, addD1.Column) & myTable(resD2.Row, addD2.Column)
|
||||
Case addD1.Row <> addD2.Row And addD1.Column <> addD2.Column
|
||||
'different rows, different columns
|
||||
resD1.Row = addD1.Row
|
||||
resD2.Row = addD2.Row
|
||||
resD1.Column = addD2.Column
|
||||
resD2.Column = addD1.Column
|
||||
SwapPairsEncoding = myTable(resD1.Row, resD1.Column) & myTable(resD2.Row, resD2.Column)
|
||||
End Select
|
||||
End Function
|
||||
|
||||
Private Function Decode(s As String) As String
|
||||
Dim t, i&, j&, e&
|
||||
t = Split(s, " ")
|
||||
e = UBound(t) - 1
|
||||
'swap the pairs
|
||||
For i = LBound(t) To UBound(t)
|
||||
t(i) = SwapPairsDecoding(CStr(t(i)))
|
||||
Next
|
||||
'remove "X"
|
||||
For i = LBound(t) To e
|
||||
If Right(t(i), 1) = "X" And Left(t(i), 1) = Left(t(i + 1), 1) Then
|
||||
t(i) = Left(t(i), 1) & Left(t(i + 1), 1)
|
||||
For j = i + 1 To UBound(t) - 1
|
||||
t(j) = Right(t(j), 1) & Left(t(j + 1), 1)
|
||||
Next j
|
||||
If Right(t(j), 1) = "X" Then
|
||||
ReDim Preserve t(j - 1)
|
||||
Else
|
||||
t(j) = Right(t(j), 1) & "X"
|
||||
End If
|
||||
ElseIf Left(t(i + 1), 1) = "X" And Right(t(i), 1) = Right(t(i + 1), 1) Then
|
||||
For j = i + 1 To UBound(t) - 1
|
||||
t(j) = Right(t(j), 1) & Left(t(j + 1), 1)
|
||||
Next j
|
||||
If Right(t(j), 1) = "X" Then
|
||||
ReDim Preserve t(j - 1)
|
||||
Else
|
||||
t(j) = Right(t(j), 1) & "X"
|
||||
End If
|
||||
End If
|
||||
Next
|
||||
Decode = Join(t, " ")
|
||||
End Function
|
||||
|
||||
Private Function SwapPairsDecoding(s As String) As String
|
||||
Dim r As Integer, c As Integer, d1 As String, d2 As String, Flag As Boolean
|
||||
Dim addD1 As Adress, addD2 As Adress, resD1 As Adress, resD2 As Adress
|
||||
d1 = Left(s, 1): d2 = Right(s, 1)
|
||||
For r = 1 To 5
|
||||
For c = 1 To 5
|
||||
If d1 = myTable(r, c) Then addD1.Row = r: addD1.Column = c
|
||||
If d2 = myTable(r, c) Then addD2.Row = r: addD2.Column = c
|
||||
If addD1.Row <> 0 And addD2.Row <> 0 Then Flag = True: Exit For
|
||||
Next
|
||||
If Flag Then Exit For
|
||||
Next
|
||||
Select Case True
|
||||
Case addD1.Row = addD2.Row And addD1.Column <> addD2.Column
|
||||
'same row, different columns
|
||||
resD1.Column = IIf(addD1.Column - 1 = 0, 5, addD1.Column - 1)
|
||||
resD2.Column = IIf(addD2.Column - 1 = 0, 5, addD2.Column - 1)
|
||||
SwapPairsDecoding = myTable(addD1.Row, resD1.Column) & myTable(addD2.Row, resD2.Column)
|
||||
Case addD1.Row <> addD2.Row And addD1.Column = addD2.Column
|
||||
'same columns, different rows
|
||||
resD1.Row = IIf(addD1.Row - 1 = 0, 5, addD1.Row - 1)
|
||||
resD2.Row = IIf(addD2.Row - 1 = 0, 5, addD2.Row - 1)
|
||||
SwapPairsDecoding = myTable(resD1.Row, addD1.Column) & myTable(resD2.Row, addD2.Column)
|
||||
Case addD1.Row <> addD2.Row And addD1.Column <> addD2.Column
|
||||
'different rows, different columns
|
||||
resD1.Row = addD1.Row
|
||||
resD2.Row = addD2.Row
|
||||
resD1.Column = addD2.Column
|
||||
resD2.Column = addD1.Column
|
||||
SwapPairsDecoding = myTable(resD1.Row, resD1.Column) & myTable(resD2.Row, resD2.Column)
|
||||
End Select
|
||||
End Function
|
||||
Loading…
Add table
Add a link
Reference in a new issue