Basic encrypting of a text file

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?

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: