Als eerste:
- Kopieer de onderstaande code middels Ctrl + C
- Druk op de toetscombinatie ALT + F11 om de Visual Basic Editor te openen
- Druk op de toetscombinatie ALT + N om het menu Invoegen te openen
- Druk op M om een standaard module in te voegen
- Daar waar de cursor knippert voeg je de code in middels Ctrl + V
- Druk op de toetscombinatie ALT + Q om de Editor af te sluiten en terug te keren naar Excel
Option Explicit
' === MAIN DEMO: RSA with text + worksheet output ===
Public Sub RSAMain()
Dim e As Long, d As Long, n As Long
Dim p As Long, q As Long
Dim msg As String
Dim blocks As Variant, encBlocks() As Long, decBlocks() As Long
Dim i As Long
Dim ws As Worksheet
Dim blockSize As Long
' Choose primes
p = 7919: q = 1009
' Generate keys
Call GenerateKeys(e, d, n, p, q)
If e = -1 Or d = -1 Then MsgBox "Key generation failed": Exit Sub
' Choose message and block size
msg = "THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG"
blockSize = 2 ' group 2 characters per block
' Convert to numeric blocks
blocks = TextToBlocks(msg, blockSize)
ReDim encBlocks(LBound(blocks) To UBound(blocks))
ReDim decBlocks(LBound(blocks) To UBound(blocks))
' Encrypt each block
For i = LBound(blocks) To UBound(blocks)
encBlocks(i) = Encrypt(blocks(i), e, n)
Next i
' Decrypt each block
For i = LBound(blocks) To UBound(blocks)
decBlocks(i) = Decrypt(encBlocks(i), d, n)
Next i
' Prepare worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets("RSA")
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "RSA"
End If
On Error GoTo 0
ws.Cells.Clear
' Write keys
ws.Range("A1").Value = "Choose Primes (p, q)"
ws.Range("B1").Value = "(" & p & ", " & q & ")"
ws.Range("A2").Value = "Public Key (e, n)"
ws.Range("B2").Value = "(" & e & ", " & n & ")"
ws.Range("A3").Value = "Private Key (d, n)"
ws.Range("B3").Value = "(" & d & ", " & n & ")"
' Write messages
ws.Range("A5").Value = "Original Message:"
ws.Range("B5").Value = msg
ws.Range("A7").Value = "Encrypted Blocks:"
For i = LBound(encBlocks) To UBound(encBlocks)
ws.Cells(7, i + 1).Value = encBlocks(i)
Next i
ws.Range("A9").Value = "Decrypted Blocks (numbers):"
For i = LBound(decBlocks) To UBound(decBlocks)
ws.Cells(9, i + 1).Value = decBlocks(i)
Next i
ws.Range("A11").Value = "Decrypted Text:"
ws.Range("B11").Value = BlocksToText(decBlocks, blockSize)
End Sub
' === Helper functions (same as before) ===
Private Function ModD(ByVal a As Double, ByVal b As Double) As Double
If b = 0 Then
ModD = 0
Exit Function
End If
ModD = a - Int(a / b) * b
If ModD < 0 Then ModD = ModD + b
End Function
Public Function IsPrime(ByVal num As Long) As Boolean
Dim i As Long
If num < 2 Then IsPrime = False: Exit Function
If num = 2 Then IsPrime = True: Exit Function
If (num Mod 2) = 0 Then IsPrime = False: Exit Function
For i = 3 To CLng(Sqr(num)) Step 2
If (num Mod i) = 0 Then IsPrime = False: Exit Function
Next i
IsPrime = True
End Function
Public Function PowerMod(ByVal base As Long, ByVal expo As Long, ByVal m As Long) As Long
Dim res As Double, tBase As Double, e As Long
res = 1#: tBase = ModD(base, m): e = expo
While e > 0
If (e And 1) = 1 Then res = ModD(res * tBase, m)
tBase = ModD(tBase * tBase, m)
e = e \ 2
Wend
PowerMod = CLng(ModD(res, m))
End Function
Public Function ModInverse(ByVal a As Long, ByVal m As Long) As Long
Dim m0 As Long, t As Long, q As Long
Dim x0 As Long, x1 As Long, tmp As Long
m0 = m
x0 = 0
x1 = 1
If m = 1 Then
ModInverse = 0
Exit Function
End If
While a > 1
If m = 0 Then
ModInverse = -1 ' no inverse
Exit Function
End If
q = a \ m
tmp = m
m = a Mod m
a = tmp
tmp = x0
x0 = x1 - q * x0
x1 = tmp
Wend
If x1 < 0 Then x1 = x1 + m0
ModInverse = x1
End Function
Public Function GCD(ByVal a As Long, ByVal b As Long) As Long
Dim tmp As Long
a = Abs(a): b = Abs(b)
Do While b <> 0
tmp = a Mod b: a = b: b = tmp
Loop
GCD = a
End Function
Public Sub GenerateKeys(ByRef e As Long, ByRef d As Long, ByRef n As Long, ByVal p As Long, ByVal q As Long)
Dim phi As Long, i As Long, candidates As Variant, cand As Long
If p <= 1 Or q <= 1 Or Not IsPrime(p) Or Not IsPrime(q) Then e = -1: d = -1: n = 0: Exit Sub
n = p * q: phi = (p - 1) * (q - 1)
candidates = Array(3, 17, 65537): e = -1
For i = LBound(candidates) To UBound(candidates)
cand = CLng(candidates(i))
If cand < phi Then If GCD(cand, phi) = 1 Then e = cand: Exit For
Next i
If e = -1 Then
For i = 3 To phi - 1 Step 2
If GCD(i, phi) = 1 Then e = i: Exit For
Next i
End If
If e = -1 Then d = -1: Exit Sub
d = ModInverse(e, phi)
End Sub
Public Function Encrypt(ByVal m As Long, ByVal e As Long, ByVal n As Long) As Long
Encrypt = PowerMod(m, e, n)
End Function
Public Function Decrypt(ByVal C As Long, ByVal d As Long, ByVal n As Long) As Long
Decrypt = PowerMod(C, d, n)
End Function
' === NEW: Text conversion helpers ===
Private Function TextToNumbers(msg As String) As Variant
Dim arr() As Long, i As Long
ReDim arr(1 To Len(msg))
For i = 1 To Len(msg)
arr(i) = Asc(Mid$(msg, i, 1)) ' each char ? ASCII code
Next i
TextToNumbers = arr
End Function
Private Function NumbersToText(nums As Variant) As String
Dim s As String, i As Long
For i = LBound(nums) To UBound(nums)
s = s & Chr$(nums(i))
Next i
NumbersToText = s
End Function
' === Text conversion helpers with block support ===
' Convert text into numeric blocks of size blockSize characters
Private Function TextToBlocks(msg As String, blockSize As Long) As Variant
Dim blocks() As Long, i As Long, j As Long
Dim blockValue As Long, charCode As Long
Dim numBlocks As Long
numBlocks = Application.Ceiling(Len(msg) / blockSize, 1)
ReDim blocks(1 To numBlocks)
For i = 1 To numBlocks
blockValue = 0
For j = 1 To blockSize
If ((i - 1) * blockSize + j) <= Len(msg) Then
charCode = Asc(Mid$(msg, (i - 1) * blockSize + j, 1))
Else
charCode = 0 ' padding if not divisible
End If
' Shift and combine into block (base 256)
blockValue = blockValue * 256 + charCode
Next j
blocks(i) = blockValue
Next i
TextToBlocks = blocks
End Function
' Convert numeric blocks back into text
Private Function BlocksToText(blocks As Variant, blockSize As Long) As String
Dim msg As String, i As Long, j As Long
Dim blockValue As Long, charCode As Long
msg = ""
For i = LBound(blocks) To UBound(blocks)
blockValue = blocks(i)
' Extract chars in reverse order
Dim tmpChars() As Long
ReDim tmpChars(1 To blockSize)
For j = blockSize To 1 Step -1
charCode = blockValue Mod 256
tmpChars(j) = charCode
blockValue = blockValue \ 256
Next j
For j = 1 To blockSize
If tmpChars(j) <> 0 Then
msg = msg & Chr$(tmpChars(j))
End If
Next j
Next i
BlocksToText = msg
End Function
THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG” is een pangram, een zin die alle letters van het alfabet bevat, en wordt vaak gebruikt voor het testen van lettertypen en toetsenborden. Deze zin gaan we versleutelen en ontsleutelen middels het RSA algoritme.
Druk op de toetscombinatie ALT + F8 om de Macro Dialoog te tonen. Dubbelklik op de macro naam, RSAMain om te starten. Of kies voor View | Macro | View Macro. Dan zie je de macro naam staan: RSAMain. Klik op Run. De code voegt een nieuw werkblad in met de naam RSA met daarop een samenvatting van wat gebeurd is.
Samenvatting op werkblad:
