Access VBA Encryption - AES256 Cipher for Text strings?

[theDBguy]

Update:

Colin,
I examined the code in your example for RC4 encryption. It was one of the many i came across while searching for a sufficient algorithm. Albeit, one of the least favorited of the bunch... The mistake the author made was 1.) not fixing his error 2.) superficially patching a function as critical as an encryption device with "On Error Resume Next"... Shameful!!! Other than that, I am a fan.

The code errors when it gets a subscript error when he assigns to the Key() array in first loop. I made some modifications to the code which handles this, as I really wasn't able to figure out how to properly solve this error. Someone else probably can with little effort.

The last thing I did was (somewhat crudely) apply a Base64 arg. When set, the output is converted to Base 64, which plays much better with Access. The principle reason full ASCII isn't ideal with Access is because there will be inevitable SQL Syntax clashes. Suppose the encryption text is outputted by the cipher and results in a leading or trailing character of any SQL operator (ex: ",',>,<), there will inevitably be a, Error 3075 syntax collision with a statement such as...

SQL = "SELECT * FROM Accounts WHERE ID = '" & EncryptedText & "';"

And I can say just in development typing random values for debugging my application, I came across way more instances of that clash than I was comfortable with... Maybe there's a SQL work-around with syntax.

Whether this Base64 conversion implements weaknesses into the algorithm, I'm not sure. I don't believe it has an impact.

Attached is a .txt of the module, which contains the cipher, as well as 2 supporting functions and 1 test function.


-Regards

Hi. Please pardon me for jumping in. Out of curiosity, I downloaded the modified RC4 attachment and gave it a try. This is what I got. Is this correct, or did I do something wrong?

 

[cheekybuddha]

There appears to be an error in the code here:

' ...
If Len(Pass) > 256 Then
    Key() = StrConv(Left$(Pass, 256), vbFromUnicode)
Else
    Key() = StrConv(Key, vbFromUnicode)
End If
' ...

My guess is that it should be:

' ...
If Len(Pass) > 256 Then
    Key() = StrConv(Left$(Pass, 256), vbFromUnicode)
Else
    Key() = StrConv(Pass, vbFromUnicode)
End If
' ...

 

[ironfelix717]

@cheekybuddha

I don't receive the subscript error there, i receive it on this line:

For x = 0 To 255
    Y = (Y + RB(x) + Key(x Mod Len(pass))) Mod 256  '<--------------HERE
    Temp = RB(x)
    RB(x) = RB(Y)
    RB(Y) = Temp
Next x

Edit: It occurs when x = 0.

 

[cheekybuddha]

Yes, because UBound(Key) = -1

(Key() = StrConv(Key, vbFromUnicode) yields no array)

 

[ironfelix717]

Yes, because UBound(Key) = -1

(Key() = StrConv(Key, vbFromUnicode) yields no array)

Yep, got ya. Just saw that prior to reading your message. That line of code would appear to be unique to my version. It must have been a re-type or something and became an error. Whoops.

Original: http://www.freevbcode.com/ShowCode.asp?ID=4398

If Len(Password) > 256 Then
    Key() = StrConv(Left$(Password, 256), vbFromUnicode)
Else
    Key() = StrConv(Password, vbFromUnicode)
End If

My error:

If Len(Pass) > 256 Then
    Key() = StrConv(Left$(Pass, 256), vbFromUnicode)
Else
    Key() = StrConv(Key, vbFromUnicode)
End If

Neverthless---- that doesn't solve it. In either the original or my code. The original had that line right the whole time, it still produces a subscript error.

 

[cheekybuddha]

The error is due to this:

' ...
  ByteArray() = StrConv(val, vbFromUnicode)
 
  For X = 0 To Len(val)
' ...

it should be:

' ...
  ByteArray() = StrConv(val, vbFromUnicode)
 
  For X = 0 To Len(val) - 1
' ...

Or probably better:

' ...
  ByteArray() = StrConv(val, vbFromUnicode)
 
  For X = 0 To UBound(ByteArray)
' ...

 

[isladogs]

Sorry I've been offline most of the day and have only just seen your reply.
Since then, there has been further discussion about your code modifications which is not part of my answer below

You said, "I tried removing the Resume Next line and got no errors on testing". That is inconsistent with that you say above, which is why in my last post I explained that your code does error. And it errors 100% of the time if the On Error Resume Next is removed. Regardless, as I argued, this isn't the way I'm going to handle a function as critical as this - whether or not you've used it for 15 years - and I offered my modified solution to this forum which i've explained the advantages of several times now... I would like to solve this Error #9 permanently because i think its a pretty simple fix, i just can't seem to understand why the array is out of assignment.

I agree my replies on this issue were inconsistent. Apologies.
I didn't get an error originally but now I get the same error 9 as you. No idea why that wasn't the case before

You can certainly change the code as follows:

Public Function RC4(ByVal Expression As String, ByVal Password As String) As String
   On Error GoTo Err_Handler
   
    Dim rb(0 To 255) As Integer, x As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, temp As Byte
   
    If Len(Password) = 0 Then
        Exit Function
    End If
    If Len(Expression) = 0 Then
        Exit Function
    End If
   
    If Len(Password) > 256 Then
        Key() = StrConv(Left$(Password, 256), vbFromUnicode)
    Else
        Key() = StrConv(Password, vbFromUnicode)
    End If
   
    For x = 0 To 255
        rb(x) = x
    Next x
   
    x = 0
    Y = 0
    Z = 0
    For x = 0 To 255
        Y = (Y + rb(x) + Key(x Mod Len(Password))) Mod 256
        temp = rb(x)
        rb(x) = rb(Y)
        rb(Y) = temp
    Next x
   
    x = 0
    Y = 0
    Z = 0
    ByteArray() = StrConv(Expression, vbFromUnicode)
    For x = 0 To Len(Expression)
        Y = (Y + 1) Mod 256
        Z = (Z + rb(Y)) Mod 256
        temp = rb(Y)
        rb(Y) = rb(Z)
        rb(Z) = temp
        ByteArray(x) = ByteArray(x) Xor (rb((rb(Y) + rb(Z)) Mod 256))
    Next x
   
    RC4 = StrConv(ByteArray, vbUnicode)
   
Exit_Handler:
    Exit Function
   
Err_Handler:
    If Err = 9 Then 'out of range
        Resume Next
    Else
        MsgBox "Error " & Err.Number & " " & Err.Description & " in RC4function", vbCritical, "Encryption Error"
    End If
   
End Function

However, how is that any better than the original as it causes error 9 each time.

I've experimented with using Long instead of integer & integer instead of byte but doing so causes error 13 - type mismatch
As I'm happy with how the original version performs, I'm not going to spend further time on this point

Regarding the query issue:

Assume this example:

SQL = "SELECT * FROM Accounts Where ID = '" & RC4(txtUserID) & "';"

txtUserID contains plaintext and the table Accounts contains IDs that are all encrypted.

If RC4 produces leading or trailing special chars that collide with SQL, you will have a bad time, hence Base64 was added.

Sorry but so far I can't replicate an issue with this
However, I see no reason to encrypt user IDs - in fact in my EncryptedNoStrings example app, I encrypt all fields except for the user ID.

 

[cheekybuddha]

Same error in your code, Colin:

' ...
    ByteArray() = StrConv(Expression, vbFromUnicode)
    For x = 0 To Len(Expression)
' ...

Resolve with:

' ...
    ByteArray() = StrConv(Expression, vbFromUnicode)
    For x = 0 To UBound(ByteArray)
' ...

 

[isladogs]

Hi David
Not my code but I agree that fixes the error 9 issue. Many thanks

Amended code:

'##############################################################
'# RC4 encryption function
'# Author: Andreas J”nsson http://www.freevbcode.com/ShowCode.asp?ID=4398
'# RC4 is a stream cipher designed by Rivest for RSA Security.
'# Modified 31/05/2020 based on suggestion by David Marten(@cheekybuddha)
'##############################################################
Public Function RC4(ByVal Expression As String, ByVal Password As String) As String
   ' On Error Resume Next
   On Error GoTo Err_Handler
   
    Dim rb(0 To 255) As Integer, x As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, temp As Byte
   
    If Len(Password) = 0 Then
        Exit Function
    End If
    If Len(Expression) = 0 Then
        Exit Function
    End If
   
    If Len(Password) > 256 Then
        Key() = StrConv(Left$(Password, 256), vbFromUnicode)
    Else
        Key() = StrConv(Password, vbFromUnicode)
    End If
   
    For x = 0 To 255
        rb(x) = x
    Next x
   
    x = 0
    Y = 0
    Z = 0
    For x = 0 To 255
        Y = (Y + rb(x) + Key(x Mod Len(Password))) Mod 256
        temp = rb(x)
        rb(x) = rb(Y)
        rb(Y) = temp
    Next x
   
    x = 0
    Y = 0
    Z = 0
    ByteArray() = StrConv(Expression, vbFromUnicode)
    'For x = 0 To Len(Expression) 'old code which caused error 9 - out of range
    For x = 0 To UBound(ByteArray) 'modified 31/05/2020
        Y = (Y + 1) Mod 256
        Z = (Z + rb(Y)) Mod 256
        temp = rb(Y)
        rb(Y) = rb(Z)
        rb(Z) = temp
        ByteArray(x) = ByteArray(x) Xor (rb((rb(Y) + rb(Z)) Mod 256))
    Next x
   
    RC4 = StrConv(ByteArray, vbUnicode)
   
Exit_Handler:
    Exit Function
   
Err_Handler:
    MsgBox "Error " & Err.Number & " " & Err.Description & " in RC4 function", vbCritical, "Encryption Error"
    Resume Exit_Handler
   
End Function

 

[cheekybuddha]

I wouldn't have looked at it if Leo hadn't highlighted the other error above!

 

[theDBguy]

I wouldn't have looked at it if Leo hadn't highlighted the other error above!

And thanks for looking into it. Cheers!

 

[ironfelix717]

@cheekybuddha
Awesome! We have a fix. Thank you. The fixed code for the modified version:

Public Function EncryptRC4(ByVal val As String, ByVal pass As String, _
Optional Base64 As Boolean = True) As String
'---------------------------------------------------------
'RC4 CIPHER, INCLUDES BASE64 OUTPUT OPTION
'CODE MODIFICATION BY @IronFelix717 : 5.31.20
'ORIGINAL:  Andreas J”nsson _
            http://www.freevbcode.com/ShowCode.asp?ID=4398
'REF:       https://tinyurl.com/yans3sx4
'---------------------------------------------------------
Dim rb(0 To 255)    As Integer
Dim x               As Long
Dim Y               As Long
Dim Z               As Long
Dim temp            As Byte
Dim Key()           As Byte
Dim ByteArray()     As Byte
Dim IsEncrypted     As Boolean
Dim PREFIX          As String
'------------------------------------
PREFIX = "VB_X"  'ecryption prefix _
                  change as desired
'------------------------------------
On Error GoTo Handler

If Len(pass) = 0 Or Len(val) = 0 _
                 Or Len(pass) > 256 Then
                 MsgBox "Error in RC4, pass or val invalid length"
                 EncryptRC4 = ""
                 Exit Function
Else
    If Left(val, 4) = PREFIX Then
        IsEncrypted = True
        val = Right(val, Len(val) - Len(PREFIX))
       
        If Base64 = True Then
            val = StrConv(DecodeBase64(val), vbUnicode)
        End If
    End If
End If

If Len(pass) > 256 Then
    Key() = StrConv(Left$(pass, 256), vbFromUnicode)
Else
    Key() = StrConv(pass, vbFromUnicode)
End If

For x = 0 To 255
    rb(x) = x
Next x

x = 0: Y = 0: Z = 0

For x = 0 To 255
    Y = (Y + rb(x) + Key(x Mod Len(pass))) Mod 256
    temp = rb(x)
    rb(x) = rb(Y)
    rb(Y) = temp
Next x

x = 0: Y = 0: Z = 0

ByteArray() = StrConv(val, vbFromUnicode)

For x = 0 To UBound(ByteArray)
    Y = (Y + 1) Mod 256
    Z = (Z + rb(Y)) Mod 256
    temp = rb(Y)
    rb(Y) = rb(Z)
    rb(Z) = temp
    ByteArray(x) = ByteArray(x) Xor (rb((rb(Y) + rb(Z)) Mod 256))
Next x

    Select Case True
        Case Base64 = True And IsEncrypted = False
        'Caller requests B64, passed input is plain text
            EncryptRC4 = StrConv(ByteArray, vbUnicode)
            EncryptRC4 = PREFIX & EncodeBase64(EncryptRC4)
        Case Base64 = False And IsEncrypted = True
        'Caller rejects B64, passed input is encrypted
            EncryptRC4 = StrConv(ByteArray, vbUnicode)
       
        Case Base64 = True And IsEncrypted = True
        'passed input is encrypted B64
            EncryptRC4 = StrConv(ByteArray, vbUnicode)
       
        Case Base64 = False And IsEncrypted = False
        'caller reject B64, passed input is plain text
            EncryptRC4 = StrConv(ByteArray, vbUnicode)
    End Select
Exit Function
Handler:
    MsgBox "Error:  Encryption failed - " & vbCrLf & _
                vbCrLf & "Error " & Err.Number & " : " & Err.Description
End Function

Function EncodeBase64(text As String) As String
'STRING ARG, NOT BYTE ARRAY
  Dim arrData() As Byte
  arrData = StrConv(text, vbFromUnicode)

  Dim objXML As MSXML2.DOMDocument
  Dim objNode As MSXML2.IXMLDOMElement

  Set objXML = New MSXML2.DOMDocument
  Set objNode = objXML.createElement("b64")

  objNode.DataType = "bin.base64"
  objNode.nodeTypedValue = arrData
  EncodeBase64 = objNode.text

  Set objNode = Nothing
  Set objXML = Nothing
End Function

Private Function DecodeBase64(Base64 As String) As Variant
'RETURNS BYTE ARRAY FOR B64 STRING
    Dim xmlDoc As Object
    Dim xmlNode As Object
   
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    Set xmlNode = xmlDoc.createElement("b64")
   
    xmlNode.DataType = "bin.base64"
    xmlNode.text = Base64
   
    DecodeBase64 = xmlNode.nodeTypedValue
End Function

 

[ironfelix717]

@isladogs

However, I see no reason to encrypt user IDs - in fact in my EncryptedNoStrings example app, I encrypt all fields except for the user ID.

So..if its not an ID. Any field can be queried.

Sorry but so far I can't replicate an issue with this.

If you're willing to accept the risk that a SQL operator is not outputted, then that's your prerogative. I spent some time tonight cobbling together a crude but practical analysis tool. It detects SQL syntax collisions and I must say i hope you will consider the results. Though I wasn't surprised I would find some conflicts, I found more than I expected.

Analysis Tool:
There are 2 main functions of the app.
The first that it will do is a test run on specified x samples with a user specified password. The sample data that is being encrypted in the DB is Top 100 most common male names, i pulled from a gov website. If you're curious on that source I can provide it. A random name is pulled from a table and then a random 3 digit integer is appended to the end of the name, simulating a password (albeit, very weak) style string. It reports the 3075 error results in the form. Any error reported in the listbox can further be analyzed by double clicking the listbox and the db will attempt to assign the encrypted value to the WHERE clause in a local query. It inevitably will fail.

The second feature is a batch trial. It runs the test 100 times and reports the frequency of collisions in a table. I added this feature because its interesting to export to Excel and analyze the results. (note: obviously you don't want to crank up the sample size and then execute a batch trial you might be locked up for awhile. But it runs pretty fast. If anything this RC4 algorithm is wicked fast.)

Results:
Running the test using passphrase "HelloWorld!" with a test size of 100 executions resulted in a batch trial (100^2 samples) that on average reported ~5.5 errors per run, for a total of 551 errors reported through the 100 trials (100^2 samples).

In other words, 551/10,000 (5.5%) of the time, there was a collision in my trials. Your mileage may vary. This is a crude test and Lord knows there are statisticians + cryptographers somewhere tweaking. But I think its practical enough that it can give the user some idea of whether they will experience an Error 3075.

I prefer to just use Base64 and call it a day.

-Regards

 

[isladogs]

I spent some time tonight cobbling together a crude but practical analysis tool. It detects SQL syntax collisions and I must say i hope you will consider the results. Though I wasn't surprised I would find some conflicts, I found more than I expected.

Thanks for sharing your analysis tool which I've downloaded.
I will investigate it properly in the next couple of days and report back

 

[isladogs]

@ironfelix717
Apologies for the delay in responding.
Thanks once again for uploading your application

I've been busy on various projects that have meant I've spent little time on my computer.
However, I've now had time to look at your app.
I found it very interesting but it is, I believe, based on a flawed approach.

Some comments:
1. Your RandNumber function is incorrect and will result in some output values above the set upper value
It should be

Function RandNumber(lower As Integer, upper As Integer) As Integer
    Randomize
  '  RandNumber = Int(upper * Rnd) + lower 'OLD code
    RandNumber = Int((upper - lower + 1) * Rnd + lower) 'NEW code
End Function

However this is not the cause of the error 3075 occurrences

NOTE: I moved this function into modFunctions for testing purposes

2. Error 3075 occurs because you are doing an invalid test as part of your RunTest procedure.
As I've said more than once during this thread, whenever a password or other data is encrypted, the code should ALWAYS test against the decrypted value whether its a query or recordset

So this code section should be changed as follows:

 For i = 1 To tbSamples
    'Plaintext val is randomly selected name + random number between 100-1000
    val = GetRandomName & RandNumber(100, 1000)
    
    'encrypted test RC4 NON-Base64
    encr = RC4(val, tbPass)
    
    'This is a test query to determine whether var 'encr' is invalid for sql.
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM Top100Male WHERE FName = '" & encr & "';") 'INCORRECT
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM Top100Male WHERE FName = '" & RC4(encr,tbPass) & "';") 'CORRECT APPROACH
    rs.Close
   
Next i

AFAIK, doing that means you will NEVER get error 3075.
As a check, I've run multiple tests using your modified app with no errors
ALL my code which tests for encrypted data works on that basis and, as already stated, it means neither I nor any of my clients have ever had any issues.

I hope my answer is helpful to you