Basic encrypting of a text file

Question

I am trying to encrypt a file. I don't need fancy encrypting, just need to keep wandering eyes off of it. I found a function called szEncryptDecrypt online (https://www.devx.com/tips/Tip/5676) that would be perfect for what I need, as it is simple to use, and obscures the data. However, I can't seem to get it working when reading from a file. Passing a string to it in a macro and decrypting it again works fine, but writing to a file then reading it does not work.

I have a write sub, a read sub and the encryption sub. The read a write sub appear to work correctly if non encrypted data is used (unless there are hidden characters it is getting also).

I tried the trim function on the string before decrypting it, but that did not work.

Option Compare Database Sub WriteSettingsFile() Dim db As DAO.Database Dim fld As DAO.Field Set db = CurrentDb 'Open Setings File name Dim filePath As String Dim TextFile As Integer TextFile = FreeFile filePath = Application.CurrentProject.Path & "\settings.cfg" Open filePath For Output As TextFile Print #TextFile, szEncryptDecrypt("Hello World") Close TextFile End Sub Sub ReadSettingsFile() Dim strFilename As String strFilename = Application.CurrentProject.Path & "\settings.cfg" Dim strTextLine As String Dim iFile As Integer: iFile = FreeFile Open strFilename For Input As #iFile Do Until EOF(1) Line Input #1, strTextLine MsgBox strTextLine 'Not Encrypted MsgBox szEncryptDecrypt(strTextLine) 'Encrypted Loop Close #iFile End Sub Function szEncryptDecrypt(ByVal szData As String) As String ' This key value can be changed to alter the encryption, ' but it must be the same for both encryption and decryption. Const KEY_TEXT As String = "asdfghjkl" ' The KEY_OFFSET is optional, and may be any value 0-64. ' Likewise, it needs to be the same coming/going. Const KEY_OFFSET As Long = 0 Dim bytKey() As Byte Dim bytData() As Byte Dim lNum As Long Dim szKey As String For lNum = 1 To ((Len(szData) \ Len(KEY_TEXT)) + 1) szKey = szKey & KEY_TEXT Next lNum bytKey = Left$(szKey, Len(szData)) bytData = szData For lNum = LBound(bytData) To UBound(bytData) If lNum Mod 2 Then bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) + KEY_OFFSET) Else bytData(lNum) = bytData(lNum) Xor (bytKey(lNum) - KEY_OFFSET) End If Next lNum szEncryptDecrypt = bytData End Function Sub TestEncrypt() 'This sub works fine Dim str As String str = szEncryptDecrypt("Hello World!") MsgBox "Encrypted" & vbNewLine & str MsgBox "Decrypted" & vbNewLine & szEncryptDecrypt(str) End Sub

Is there a better encryption function for use with text files?

I also modified the KEY_TEXT and KEY_OFFSET values. KEY_TEXT doesn't seem to affect it. When KEY_OFFSET is 0, it decrypts most of the text, but cuts off the last few characters. A value of 1 returns text characters, but they are not correct. Any other character returns only question marks '???????'. — dms292
– dms292, Commented Apr 28, 2021 at 5:07

Gustav · Accepted Answer · 2021-10-04 09:36:46Z

Yeah, that encryption function you've found is very simple, but very poor. It does simple XORing with an offset. That means if someone can get you to encrypt a known string and can read the output, they can calculate the key. Also, there's no chaining, so we have no diffusion, repeating patterns in the text will lead to the same output, thus common patterns can be inferred.

I've worked on a complicated approach to encryption myself, using AES-128 in CBC mode. However, the code required is fairly long. It uses the CNG API to do the encryption. Others use .Net, which in turn uses CNG, but can result in shorter code. I prefer not to, since that relies on COM objects and those can be overridden.

Let's start with usage: it's simple. Use EncryptString(StringToEncrypt, Key) to encrypt a string, and DecryptString(StringToDecrypt, Key) to decrypt it again. It uses Base64 encoding to represent the encrypted string, so output should be safe to store in fields that only accept valid unicode strings (also in contrast to the implementation you found).

Then, the fundamentals. AES-128 in CBC mode is a block cipher, so it requires a fixed length key, and also encrypts in full blocks of 128 bits. To work around this, we use SHA1 to reduce our key to a fixed length, and store the length of the input data inside the encrypted string to ignore any padding (additional characters at the end).

Then, in CBC mode, it also requires an initialization vector (IV). We randomly generate that one, and store it without encryption (since we need it to decrypt) at the end of the string. Since we generate the IV randomly, encrypting the same string two times with the same key will result in entirely different encrypted strings, which is often desirable (if you encrypt a password, you don't want someone to be able to check who all have the same password as you).

This code also hashes the data, and stores the encrypted hash with the data. This means it can easily check if your key was valid, and it will not return anything if it was not.

The resulting code is fairly lengthy. It could be reduced by not doing the Base64 encoding in VBA, not using a cryptographically secure random number generator, or using .Net for everything, but that's not desirable imo. I recommend pasting it in a separate module.

Option Compare Binary Option Explicit Public Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long Public Declare PtrSafe Function BCryptSetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbInput As Any, ByVal cbInput As Long, ByVal dfFlags As Long) As Long Public Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long Public Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long Public Declare PtrSafe Function BCryptGenRandom Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, pbBuffer As Any, ByVal cbBuffer As Long, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptGenerateSymmetricKey Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef hKey As LongPtr, pbKeyObject As Any, ByVal cbKeyObject As Long, pbSecret As Any, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptEncrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptDecrypt Lib "BCrypt.dll" (ByVal hKey As LongPtr, pbInput As Any, ByVal cbInput As Long, pPaddingInfo As Any, pbIV As Any, ByVal cbIV As Long, pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dwFlags As Long) As Long Public Declare PtrSafe Function BCryptDestroyKey Lib "BCrypt.dll" (ByVal hKey As LongPtr) As Long Public Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32.dll" (Destination As Any, Source As Any, ByVal Length As LongPtr) Const BCRYPT_BLOCK_PADDING As Long = &H1 Public Type QuadSextet s1 As Byte s2 As Byte s3 As Byte s4 As Byte End Type Public Function ToBase64(b() As Byte) As String Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim l As Long Dim output As String Dim UBoundOut As Long UBoundOut = UBound(b) + 1 If UBoundOut Mod 3 <> 0 Then UBoundOut = UBoundOut + (3 - UBoundOut Mod 3) End If UBoundOut = (UBoundOut \ 3) * 4 output = String(UBoundOut, vbNullChar) Dim qs As QuadSextet For l = 0 To (UBound(b) - 2) \ 3 qs = BytesToQuadSextet(b(l * 3), b(l * 3 + 1), b(l * 3 + 2)) Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1) Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1) Mid(output, (l * 4) + 3, 1) = Mid(Base64Table, qs.s3 + 1, 1) Mid(output, (l * 4) + 4, 1) = Mid(Base64Table, qs.s4 + 1, 1) Next If UBound(b) + 1 - (l * 3) = 2 Then qs = BytesToQuadSextet(b(l * 3), b(l * 3 + 1)) Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1) Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1) Mid(output, (l * 4) + 3, 1) = Mid(Base64Table, qs.s3 + 1, 1) Mid(output, (l * 4) + 4, 1) = "=" ElseIf UBound(b) + 1 - (l * 3) = 1 Then qs = BytesToQuadSextet(b(l * 3)) Mid(output, (l * 4) + 1, 1) = Mid(Base64Table, qs.s1 + 1, 1) Mid(output, (l * 4) + 2, 1) = Mid(Base64Table, qs.s2 + 1, 1) Mid(output, (l * 4) + 3, 2) = "==" End If ToBase64 = output End Function Public Function Base64ToBytes(strBase64 As String) As Byte() Dim outBytes() As Byte Dim lenBytes As Long lenBytes = Len(strBase64) * 3 \ 4 If Right(strBase64, 1) = "=" Then lenBytes = lenBytes - 1 If Right(strBase64, 2) = "==" Then lenBytes = lenBytes - 1 ReDim outBytes(0 To lenBytes - 1) Dim l As Long Dim qs As QuadSextet For l = 0 To lenBytes - 1 Select Case l Mod 3 Case 0 qs = Base64ToQuadSextet(Mid(strBase64, (l \ 3) * 4 + 1, 4)) outBytes(l) = qs.s1 * 2 ^ 2 + (qs.s2 \ 2 ^ 4) Case 1 outBytes(l) = (qs.s2 * 2 ^ 4 And 255) + qs.s3 \ 2 ^ 2 Case 2 outBytes(l) = (qs.s3 * 2 ^ 6 And 255) + qs.s4 End Select Next Base64ToBytes = outBytes End Function Public Function BytesToQuadSextet(b1 As Byte, Optional b2 As Byte, Optional b3 As Byte) As QuadSextet BytesToQuadSextet.s1 = b1 \ 4 BytesToQuadSextet.s2 = (((b1 * 2 ^ 6) And 255) \ 4) + b2 \ (2 ^ 4) BytesToQuadSextet.s3 = (((b2 * 2 ^ 4) And 255) \ 4) + b3 \ (2 ^ 6) BytesToQuadSextet.s4 = (((b3 * 2 ^ 2) And 255) \ 4) End Function Public Function Base64ToQuadSextet(strBase64 As String) As QuadSextet Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" Base64ToQuadSextet.s1 = InStr(Base64Table, Mid(strBase64, 1, 1)) - 1 Base64ToQuadSextet.s2 = InStr(Base64Table, Mid(strBase64, 2, 1)) - 1 Base64ToQuadSextet.s3 = InStr(Base64Table, Mid(strBase64, 3, 1)) - 1 Base64ToQuadSextet.s4 = InStr(Base64Table, Mid(strBase64, 4, 1)) - 1 End Function Public Function StringToBase64(str As String) As String StringToBase64 = ToBase64(StrConv(str, vbFromUnicode)) End Function Public Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA1") As Byte() HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm) End Function Public Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte() 'Erik A, 2019 'Hash data by using the Next Generation Cryptography API 'Loosely based on https://learn.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng 'Allowed algorithms: https://learn.microsoft.com/en-us/windows/desktop/SecCNG/cng-algorithm-identifiers. Note: only hash algorithms, check OS support 'Error handling not implemented! On Error GoTo VBErrHandler Dim errorMessage As String Dim hAlg As LongPtr Dim algId As String 'Open crypto provider algId = HashingAlgorithm & vbNullChar If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) Then GoTo ErrHandler 'Determine hash object size, allocate memory Dim bHashObject() As Byte Dim cmd As String cmd = "ObjectLength" & vbNullString Dim Length As Long If BCryptGetProperty(hAlg, StrPtr(cmd), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler ReDim bHashObject(0 To Length - 1) 'Determine digest size, allocate memory Dim hashLength As Long cmd = "HashDigestLength" & vbNullChar If BCryptGetProperty(hAlg, StrPtr(cmd), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler Dim bHash() As Byte ReDim bHash(0 To hashLength - 1) 'Create hash object Dim hHash As LongPtr If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler 'Hash data If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler 'Return result NGHash = bHash ExitHandler: 'Cleanup If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0 If hHash <> 0 Then BCryptDestroyHash hHash Exit Function VBErrHandler: errorMessage = "VB Error " & Err.Number & ": " & Err.Description ErrHandler: If errorMessage <> "" Then MsgBox errorMessage Resume ExitHandler End Function Public Sub NGRandom(pData As LongPtr, lenData As Long, Optional Algorithm As String = "RNG") 'Erik A, 2019 'Fills data at pointer with random bytes 'Error handling not implemented! Dim hAlg As LongPtr Dim algId As String 'Open crypto provider algId = Algorithm & vbNullChar BCryptOpenAlgorithmProvider hAlg, StrPtr(algId), 0, 0 'Fill bytearray with random data BCryptGenRandom hAlg, ByVal pData, lenData, 0 'Cleanup BCryptCloseAlgorithmProvider hAlg, 0 End Sub Public Sub NGRandomW(Data() As Byte, Optional Algorithm As String = "RNG") If LBound(Data) = -1 Then Exit Sub NGRandom VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, Algorithm End Sub Public Function NGEncrypt(pData As LongPtr, lenData As Long, inpIV As LongPtr, inpIVLength As Long, inpSecret As LongPtr, inpSecretLength As Long) As Byte() 'Encrypt pData using AES encryption, inpIV and inpSecret 'Input: pData -> mempointer to data. lenData: amount of bytes to encrypt. inpIV: mempointer to IV. inpSecret: mempointer to 128-bits secret. 'Output: Bytearray containing encrypted data Dim errorMessage As String On Error GoTo VBErrHandler Dim hAlg As LongPtr Dim algId As String 'Open algorithm provider algId = "AES" & vbNullChar BCryptOpenAlgorithmProvider hAlg, StrPtr(algId), 0, 0 'Allocate memory to hold the KeyObject Dim cmd As String Dim keyObjectLength As Long cmd = "ObjectLength" & vbNullString BCryptGetProperty hAlg, StrPtr(cmd), keyObjectLength, LenB(keyObjectLength), 0, 0 Dim bKeyObject() As Byte ReDim bKeyObject(0 To keyObjectLength - 1) 'Check block length = 128 bits, copy IV Dim ivLength As Long Dim bIV() As Byte cmd = "BlockLength" & vbNullChar BCryptGetProperty hAlg, StrPtr(cmd), ivLength, LenB(ivLength), 0, 0 If ivLength > inpIVLength Then Debug.Print End If ReDim bIV(0 To ivLength - 1) RtlMoveMemory bIV(0), ByVal inpIV, ivLength 'Set chaining mode cmd = "ChainingMode" & vbNullString Dim val As String val = "ChainingModeCBC" & vbNullString BCryptSetProperty hAlg, StrPtr(cmd), ByVal StrPtr(val), LenB(val), 0 'Create KeyObject using secret Dim hKey As LongPtr BCryptGenerateSymmetricKey hAlg, hKey, bKeyObject(0), keyObjectLength, ByVal inpSecret, inpSecretLength, 0 'Calculate output buffer size, allocate output buffer Dim cipherTextLength As Long BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, cipherTextLength, BCRYPT_BLOCK_PADDING Dim bCipherText() As Byte ReDim bCipherText(0 To cipherTextLength - 1) 'Encrypt the data Dim dataLength As Long BCryptEncrypt hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bCipherText(0), cipherTextLength, dataLength, BCRYPT_BLOCK_PADDING 'Output the encrypted data NGEncrypt = bCipherText ExitHandler: 'Destroy the key If hKey <> 0 Then BCryptDestroyKey hKey If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0 Exit Function VBErrHandler: errorMessage = "VB Error " & Err.Number & ": " & Err.Description ErrHandler: If errorMessage <> "" Then MsgBox errorMessage Resume ExitHandler End Function Public Function NGEncryptW(pData() As Byte, pIV() As Byte, pSecret() As Byte) As Byte() NGEncryptW = NGEncrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1) End Function Public Function NGDecrypt(pData As LongPtr, lenData As Long, pIV As LongPtr, lenIV As Long, pSecret As LongPtr, lenSecret As Long) As Byte() Dim errorMessage As String On Error GoTo VBErrHandler Dim hAlg As LongPtr Dim algId As String 'Open algorithm provider algId = "AES" & vbNullChar If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) <> 0 Then GoTo ErrHandler 'Allocate memory to hold the KeyObject Dim cmd As String Dim keyObjectLength As Long cmd = "ObjectLength" & vbNullString If BCryptGetProperty(hAlg, StrPtr(cmd), keyObjectLength, LenB(keyObjectLength), 0, 0) <> 0 Then GoTo ErrHandler Dim bKeyObject() As Byte ReDim bKeyObject(0 To keyObjectLength - 1) 'Calculate the block length for the IV, resize the IV Dim ivLength As Long Dim bIV() As Byte cmd = "BlockLength" & vbNullChar If BCryptGetProperty(hAlg, StrPtr(cmd), ivLength, LenB(ivLength), 0, 0) <> 0 Then GoTo ErrHandler ReDim bIV(0 To ivLength - 1) RtlMoveMemory bIV(0), ByVal pIV, ivLength 'Set chaining mode cmd = "ChainingMode" & vbNullString Dim val As String val = "ChainingModeCBC" & vbNullString If BCryptSetProperty(hAlg, StrPtr(cmd), ByVal StrPtr(val), LenB(val), 0) <> 0 Then GoTo ErrHandler 'Create KeyObject using secret Dim hKey As LongPtr If BCryptGenerateSymmetricKey(hAlg, hKey, bKeyObject(1), keyObjectLength, ByVal pSecret, lenSecret, 0) <> 0 Then GoTo ErrHandler 'Calculate output buffer size, allocate output buffer Dim OutputSize As Long If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, ByVal 0, 0, OutputSize, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler Dim bDecrypted() As Byte ReDim bDecrypted(0 To OutputSize - 1) 'Decrypt the data Dim dataLength As Long If BCryptDecrypt(hKey, ByVal pData, lenData, ByVal 0, bIV(0), ivLength, bDecrypted(0), OutputSize, dataLength, BCRYPT_BLOCK_PADDING) <> 0 Then GoTo ErrHandler NGDecrypt = bDecrypted 'Cleanup ExitHandler: BCryptDestroyKey hKey BCryptCloseAlgorithmProvider hAlg, 0 Exit Function VBErrHandler: errorMessage = "VB Error " & Err.Number & ": " & Err.Description ErrHandler: If errorMessage <> "" Then MsgBox errorMessage GoTo ExitHandler End Function Public Function NGDecryptW(pData() As Byte, pIV() As Byte, pSecret() As Byte) As Byte() NGDecryptW = NGDecrypt(VarPtr(pData(LBound(pData))), UBound(pData) - LBound(pData) + 1, VarPtr(pIV(LBound(pIV))), UBound(pIV) - LBound(pIV) + 1, VarPtr(pSecret(LBound(pSecret))), UBound(pSecret) - LBound(pSecret) + 1) End Function Public Function EncryptData(inpData() As Byte, inpKey() As Byte) As Byte() 'SHA1 the key and data Dim keyHash() As Byte keyHash = HashBytes(inpKey, "SHA1") Dim dataHash() As Byte dataHash = HashBytes(inpData, "SHA1") Dim dataLength As Long dataLength = UBound(inpData) - LBound(inpData) + 1 Dim toEncrypt() As Byte 'To encrypt = Long (4 bytes) + dataLength + SHA1 (20 bytes) ReDim toEncrypt(0 To dataLength + 23) 'Append length (in bytes) to start of array RtlMoveMemory toEncrypt(0), dataLength, 4 'Then data RtlMoveMemory toEncrypt(4), inpData(LBound(inpData)), dataLength 'Then hash of data RtlMoveMemory toEncrypt(dataLength + 4), dataHash(0), 20 'Generate IV Dim IV(0 To 15) As Byte NGRandomW IV 'Encrypt data Dim encryptedData() As Byte encryptedData = NGEncrypt(VarPtr(toEncrypt(0)), dataLength + 24, VarPtr(IV(0)), 16, VarPtr(keyHash(0)), 16) 'Deallocate copy made to encrypt Erase toEncrypt 'Extend encryptedData to append IV ReDim Preserve encryptedData(LBound(encryptedData) To UBound(encryptedData) + 16) 'Append IV RtlMoveMemory encryptedData(UBound(encryptedData) - 15), IV(0), 16 'Return result EncryptData = encryptedData End Function Public Function DecryptData(inpData() As Byte, inpKey() As Byte, outDecrypted() As Byte) As Boolean If LBound(inpData) <> 0 Then Exit Function 'Array must start at 0 Dim arrLength As Long arrLength = UBound(inpData) + 1 'IV = 16 bytes, length = 4 bytes If arrLength < 20 Then Exit Function 'SHA1 the key Dim keyHash() As Byte keyHash = HashBytes(inpKey, "SHA1") 'Get the pointer to the IV Dim pIV As LongPtr pIV = VarPtr(inpData(UBound(inpData) - 15)) 'Last 16 bytes = IV 'Decrypt the data Dim decryptedData() As Byte decryptedData = NGDecrypt(VarPtr(inpData(0)), UBound(inpData) - LBound(inpData) - 15, pIV, 16, VarPtr(keyHash(0)), 16) 'Check we got some data If StrPtr(decryptedData) = 0 Then Exit Function ' Weirdly, this checks for uninitialized byte arrays If UBound(decryptedData) < 3 Then Exit Function 'Get the data length Dim dataLength As Long RtlMoveMemory dataLength, decryptedData(0), 4 'Check if length is valid, with invalid key length = random data If dataLength > (UBound(decryptedData) - 3) Or dataLength < 0 Then Exit Function 'Hash the decrypted data Dim hashResult() As Byte hashResult = NGHash(VarPtr(decryptedData(4)), dataLength, "SHA1") 'Verify the hash Dim l As Byte For l = 0 To 19 If hashResult(l) <> decryptedData(l + 4 + dataLength) Then 'Stored hash not equal to hash with decrypted data, key incorrect or encrypted data tampered with 'Don't touch output, return false by default Exit Function End If Next 'Initialize output array ReDim outDecrypted(0 To dataLength - 1) 'Copy data to output array RtlMoveMemory outDecrypted(0), decryptedData(4), dataLength DecryptData = True End Function Public Function EncryptString(inpString As String, inpKey As String) As String Dim Data() As Byte Data = inpString Dim key() As Byte key = inpKey EncryptString = ToBase64(EncryptData(Data, key)) End Function Public Function DecryptString(inpEncryptedString As String, inpKey As String) As String Dim Data() As Byte Data = Base64ToBytes(inpEncryptedString) Dim key() As Byte key = inpKey Dim out() As Byte DecryptData Data, key, out DecryptString = out End Function

And an easy check in the immediate window to see it works:

?EncryptString("Secret data", "Key") 'Returns seemingly random data, changing every call ?DecryptString(EncryptString("Secret data", "Other key"), "Other key") 'Test that long keys and long strings work, returns True since encrypted + decrypted = original ?DecryptString(EncryptString(String(100000, "A"), String(10000, "B")), String(10000, "B")) = String(100000, "A")

Erik, I wish to include most of this module in a project. How can I credit you properly?
@Gustav A link to this post + my username + date of retrieval in a comment will do, thanks for asking
@Gustav Be sure to use the recent edit, the previous version assumed the decrypted data was valid and could segfault if it wasn't and the length portion gave a large number
Decrypting will return no output if Option Compare Text is in force. See edit, please.

Gustav · Accepted Answer · 2021-04-28 08:15:32Z

First, I would certainly recommend Erik's route but, to answer your question directly, your trouble is, that you generate binary data with non-ascii characters.

That, however, can be solved by using Base64 encoding/decoding like this:

Sub WriteSettingsFile() Dim db As DAO.Database Dim fld As DAO.Field Set db = CurrentDb 'Open Setings File name Dim FilePath As String Dim TextFile As Integer TextFile = FreeFile FilePath = Application.CurrentProject.Path & "\settings.cfg" Open FilePath For Output As #TextFile Print #TextFile, Encode64(szEncryptDecrypt("Hello World")) Close #TextFile End Sub Sub ReadSettingsFile() Dim strFilename As String Dim strTextLine As String Dim TextFile As Integer TextFile = FreeFile strFilename = Application.CurrentProject.Path & "\settings.cfg" Open strFilename For Input As #TextFile Do Until EOF(1) Line Input #1, strTextLine MsgBox strTextLine ' Not decrypted MsgBox szEncryptDecrypt(Decode64(strTextLine)) ' Decrypted Loop Close #TextFile End Sub

This requires two supporting functions, and then your code starts to pile up a bit:

Option Compare Database Option Explicit Private Const clOneMask = 16515072 '000000 111111 111111 111111 Private Const clTwoMask = 258048 '111111 000000 111111 111111 Private Const clThreeMask = 4032 '111111 111111 000000 111111 Private Const clFourMask = 63 '111111 111111 111111 000000 Private Const clHighMask = 16711680 '11111111 00000000 00000000 Private Const clMidMask = 65280 '00000000 11111111 00000000 Private Const clLowMask = 255 '00000000 00000000 11111111 Private Const cl2Exp18 = 262144 '2 to the 18th power Private Const cl2Exp12 = 4096 '2 to the 12th Private Const cl2Exp6 = 64 '2 to the 6th Private Const cl2Exp8 = 256 '2 to the 8th Private Const cl2Exp16 = 65536 '2 to the 16th Public Function Encode64(ByVal sString As String) As String Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long For lTemp = 0 To 63 'Fill the translation table. Select Case lTemp Case 0 To 25 bTrans(lTemp) = 65 + lTemp 'A - Z Case 26 To 51 bTrans(lTemp) = 71 + lTemp 'a - z Case 52 To 61 bTrans(lTemp) = lTemp - 4 '1 - 0 Case 62 bTrans(lTemp) = 43 'Chr(43) = "+" Case 63 bTrans(lTemp) = 47 'Chr(47) = "/" End Select Next lTemp For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables. lPowers8(lTemp) = lTemp * cl2Exp8 lPowers16(lTemp) = lTemp * cl2Exp16 Next lTemp iPad = Len(sString) Mod 3 'See if the length is divisible by 3 If iPad Then 'If not, figure out the end pad and resize the input. iPad = 3 - iPad sString = sString & String(iPad, Chr(0)) End If bIn = StrConv(sString, vbFromUnicode) 'Load the input string. lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string. lTemp = lLen \ 72 'Added space for vbCrLfs. lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer. ReDim bOut(lOutSize) 'Make the output buffer. lLen = 0 'Reusing this one, so reset it. For lChar = LBound(bIn) To UBound(bIn) Step 3 lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes lTemp = lTrip And clOneMask 'Mask for the first 6 bits bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value lTemp = lTrip And clTwoMask 'Mask for the second set. bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate. lTemp = lTrip And clThreeMask 'Mask for the third set. bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate. bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set. If lLen = 68 Then 'Ready for a newline bOut(lPos + 4) = 13 'Chr(13) = vbCr bOut(lPos + 5) = 10 'Chr(10) = vbLf lLen = 0 'Reset the counter lPos = lPos + 6 Else lLen = lLen + 4 lPos = lPos + 4 End If Next lChar If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf. If iPad = 1 Then 'Add the padding chars if any. bOut(lOutSize) = 61 'Chr(61) = "=" ElseIf iPad = 2 Then bOut(lOutSize) = 61 bOut(lOutSize - 1) = 61 End If Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it. End Function Public Function Decode64(ByVal sString As String) As String Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String Dim lTemp As Long sString = Replace(sString, vbCr, vbNullString) 'Get rid of the vbCrLfs. These could be in... sString = Replace(sString, vbLf, vbNullString) 'either order. lTemp = Len(sString) Mod 4 'Test for valid input. If lTemp Then Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.") End If If InStrRev(sString, "==") Then 'InStrRev is faster when you know it's at the end. iPad = 2 'Note: These translate to 0, so you can leave them... ElseIf InStrRev(sString, "=") Then 'in the string and just resize the output. iPad = 1 End If For lTemp = 0 To 255 'Fill the translation table. Select Case lTemp Case 65 To 90 bTrans(lTemp) = lTemp - 65 'A - Z Case 97 To 122 bTrans(lTemp) = lTemp - 71 'a - z Case 48 To 57 bTrans(lTemp) = lTemp + 4 '1 - 0 Case 43 bTrans(lTemp) = 62 'Chr(43) = "+" Case 47 bTrans(lTemp) = 63 'Chr(47) = "/" End Select Next lTemp For lTemp = 0 To 63 'Fill the 2^6, 2^12, and 2^18 lookup tables. lPowers6(lTemp) = lTemp * cl2Exp6 lPowers12(lTemp) = lTemp * cl2Exp12 lPowers18(lTemp) = lTemp * cl2Exp18 Next lTemp bIn = StrConv(sString, vbFromUnicode) 'Load the input byte array. ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1) 'Prepare the output buffer. For lChar = 0 To UBound(bIn) Step 4 lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _ lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3)) 'Rebuild the bits. lTemp = lQuad And clHighMask 'Mask for the first byte bOut(lPos) = lTemp \ cl2Exp16 'Shift it down lTemp = lQuad And clMidMask 'Mask for the second byte bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down bOut(lPos + 2) = lQuad And clLowMask 'Mask for the third byte lPos = lPos + 3 Next lChar sOut = StrConv(bOut, vbUnicode) 'Convert back to a string. If iPad Then sOut = Left$(sOut, Len(sOut) - iPad) 'Chop off any extra bytes. Decode64 = sOut End Function

Output:

Interesting, my code comes with a native VBA Base64 encoder and decoder too, but you seem to have taken a different (slightly lengthier but probably faster) approach.
@ErikA: Oh, missed that. I haven't used this for years, just recalled I had the module and that it would solve the issue. Ran a test: For small strings like here (i.e passwords), yours is twice as fast; for longer text, yours seems to be slower as the text length increases.
@Erik A: Somewhat OT, but could you tell, please, if this method by Dropbox to "clean" a Base64 string by replacing "." and "/" with "_" and remove the trailing "=" is common: Testing the PKCE Flow
@ErikA: I've updated the Hash function to, optionally, process the text input as ANSI encoded to allow for hashing of tokens for OAuth2.
That makes sense, seems like an easy addition. Sorry, missed your previous comment, that's actually called Base64url encoding (since it's URL safe), and it's documented in an old RFC, datatracker.ietf.org/doc/html/rfc4648#section-5. It's semi-common and the RFC leaves the trailing = optional. It's why I like the Const Base64Table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" as a first line, as you can easily change that to the desired table, though a simple replace works too. Note that without the =, the data can only be decoded if it has a known length

Collectives™ on Stack Overflow

Basic encrypting of a text file

2 Answers 2

26 Comments

6 Comments

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

26 Comments

6 Comments

Linked

Related