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?
Solution
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:
- How to get the squared symbol (²) to display in a string
- Filters and then sorting
- How to avoid using Select in Excel VBA?
- How do I get a range's address including the worksheet name, but not the workbook name, in Excel VBA?
- Euro symbol not showing (VBA)
- How to extract a word in a string between two similar characters" with VBA?
- Beginner is stuck with EXCEL ETL
- How do I download CSV file from investing.com
- Edit links to a new month's file
- VBA - Copy column data to new column, if data exists, use column to the right
- VBA: initializing a string array
- How to automate a power query in VBA?
- Problem with cycling through Styles to change NextParagraphStyle - Run time error 91 - Word vba
- Excel to replace formulas with values
- VBA copy and paste a range multiple times based on cell value
- Using Excel VBA, how can i extract data from a named table and manipulate the data without changing the data in the original table?
- Trying to edit existing Macro to change Input from a Numeric Field to a Text Field
- How to format a general date to a distinct month in a combobox dropdown list in Access VBA?
- Date/Time Format VBA Access Query
- Excel VBA - deleting sheet leaves phantom sheet object in object browser
- popen command in Office VBA code generates Run-time error '32815'
- Create email if file for attachment exists
- VBA Paste in new sheet macro - getting "wrong number of arguments or invalid property assignment"
- Form built from module disappears after a few seconds
- SolidWorks API How to use SelectByID2 method
- C# DLL with [ComSourceInterfaces] Attribute Not Working in VBA WithEvents
- Better way of coding this to get the data
- How do I enter header text into the 'Goto -> Header -> Texts' menu in VA01 using SAP GUI Scripting?
- How to delete a row if the text matches a certain color
- How do I set the list of a dependant combobox in a userform in word to a range in excel based on an independent combobox