RSA Example with Excel

 

RSA Encryption with Excel Part 1.

https://youtu.be/zxMNNwvhj94

RSA_example_screencast.xlsx

0.04MB

 

RSA Encryption with Excel Part 2.

https://youtu.be/o4KamplcSeE

 

RSA Encryption with Excel Part 3.

https://youtu.be/2Y8CKXy-eRI

 

Encryption of Confidential Numbers in Excel

https://youtu.be/04Gp_ud-gLs

 

http://exceldevelopmentplatform.blogspot.com/2017/07/cryptography-vba-code-for-wikipedias.html

Cryptography - VBA code for Wikipedia's RSA example

Option Explicit
Option Private Module

Private Type udtPublicKey
    n As Currency
    e As Currency
End Type

Private Type udtPrivateKey
    n As Currency
    d As Currency
End Type

'***************************************************
'               .__
'  _____ _____  |__| ____
' /     \\__  \ |  |/    \
'|  Y Y  \/ __ \|  |   |  \
'|__|_|  (____  /__|___|  /
'      \/     \/        \/
'***************************************************

Private Sub Main()

    Dim p As Currency
    Dim q As Currency
    Dim n As Currency
    Dim lambda_n As Currency
    Dim e As Currency
    Dim d As Currency


    p = 61
    q = 53
    n = p * q
    lambda_n = Application.Lcm(p - 1, q - 1)
    e = 17
    Debug.Assert IsCoPrime(e, lambda_n)
    
    d = ModularMultiplicativeInverse(e, lambda_n)
    Debug.Assert e <> d

    Dim uPrivate As udtPrivateKey
    uPrivate.d = d
    uPrivate.n = n
    
    Dim uPublic As udtPublicKey
    uPublic.e = e
    uPublic.n = n
        
    '* m is the message to encrypt, it needs to be a number
    '* 65 is ASCII for "A"
    Dim m As Currency
    m = 65
    
    '* c is the encrypted message
    Dim c As Currency
    c = Encrypt(m, uPublic)
    
    '* m2 is the decrypted message
    Dim m2 As Currency
    m2 = Decrypt(c, uPrivate)
    
    '* and the decrypted message should match the original
    Debug.Assert m2 = m
     
End Sub


Private Function Encrypt(ByVal m As Currency, _
                    ByRef uPublic As udtPublicKey) As Currency
    If m > uPublic.n Then Err.Raise vbObjectError, , _
            "#text is bigger than modulus, no way to decipher!"
    
    Dim lLoop As Long
    Dim lResult As Currency
    lResult = 1
    For lLoop = 1 To uPublic.e
    
        lResult = ((lResult Mod uPublic.n) * (m Mod uPublic.n)) Mod uPublic.n
    Next lLoop
    Encrypt = lResult
End Function

Private Function Decrypt(ByVal c As Currency, _
                    ByRef uPrivate As udtPrivateKey) As Currency
    If c > uPrivate.n Then Err.Raise vbObjectError, , _
            "#text is bigger than modulus, no way to decipher!"
    Dim lLoop As Long
    Dim lResult As Currency
    lResult = 1
    For lLoop = 1 To uPrivate.d
        lResult = ((lResult Mod uPrivate.n) * (c Mod uPrivate.n)) Mod uPrivate.n
    Next lLoop

    
    Decrypt = lResult
End Function

Private Function IsCoPrime(ByVal a As Currency, ByVal b As Currency) As Boolean
    IsCoPrime = (Application.Gcd(a, b) = 1)
End Function

Private Function ModularMultiplicativeInverse(ByVal e As Currency, _
                    ByVal lambda_n As Currency)
    Dim lLoop As Currency
    For lLoop = 1 To lambda_n
        If lLoop <> e Then
            Dim lComp As Currency
            lComp = lLoop * e Mod lambda_n
            If lComp = 1 Then
                ModularMultiplicativeInverse = lLoop
                Exit Function
            End If
        End If
    Next
SingleExit:
End Function

 

https://gist.github.com/ooltcloud/f9b3d1f933d3d0b13cf6

Sub Main()

    ' 鍵生成
    Call GetKey(publicKey, privateKey)
    Debug.Print publicKey
    Debug.Print privateKey
    
    ' 暗号化
    encryptString = Encrypt(publicKey, "あいう")
    Debug.Print encryptString

    ' 復号
    planeString = Decrypt(privateKey, encryptString)
    Debug.Print planeString & "*"

End Sub


' 鍵生成
Sub GetKey(publicKey, privateKey)

    Set rsa = CreateObject("System.Security.Cryptography.RSACryptoServiceProvider")

    publicKey = rsa.ToXmlString(False)
    privateKey = rsa.ToXmlString(True)

End Sub

' 暗号化
Function Encrypt(key, value) As String

    Set rsa = CreateObject("System.Security.Cryptography.RSACryptoServiceProvider")

    ' 文字列を Byte 列に (UTF-16)
    Dim byteString() As Byte
    byteString = value

    ' 暗号化
    Call rsa.FromXmlString(key)
    encryptData = rsa.Encrypt(byteString, False)

    ' 暗号 Byte 列 を文字列 に
    encryptString = ""
    For Each v In encryptData
        encryptString = encryptString & Right("00" & Hex(v), 2)
    Next

    ' return
    Encrypt = encryptString

End Function

' 復号
Function Decrypt(key, value) As String

    Set rsa = CreateObject("System.Security.Cryptography.RSACryptoServiceProvider")

    ' 文字列を Byte 列 に
    byteLength = Len(value) \ 2
    
    Dim encryptData() As Byte
    ReDim encryptData(byteLength - 1)
        
    For i = 0 To byteLength - 1
        encryptData(i) = CByte("&H" & Mid(value, i * 2 + 1, 2))
    Next
   
   ' 復号
    Call rsa.FromXmlString(key)
    planeData = rsa.Decrypt(encryptData, False)
    
    ' return
    Decrypt = planeData

End Function