Encoding Files

On error resume next

' Author Eddie Jackson
' Data 3/10/2014
' Written to encode text files

'VARIABLES
Dim arrayKey, output
Set objShell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'FILES TO BE ENCODED
file1 = "text1.txt"
file2 = "text2.txt"

'UNIQUE ENCRYPTION CODE
arrayKey = ReturnKey( "encryption code ""code""" )

'ENCODE FILE HERE
output = Encode( file1, "text1.dat", arrayKey )
'DELETE PLAINTEXT
objShell.Run "%comspec% /c del /q text1.txt",0,true
'ENCODE FILE HERE
output = Encode( file2, "text2.dat", arrayKey )
'DELETE PLAINTEXT
objShell.Run "%comspec% /c del /q text2.txt",0,true

''''' DO NOT EDIT BELOW THIS LINE
Function Encode( myFileIn, myFileOut, arrayCode )
Dim i, objFSO, objFileIn, objFileOut, objStreamIn

Const ForAppending = 8
Const ForReading = 1
Const ForWriting = 2
Const TristateFalse = 0
Const TristateMixed = -2
Const TristateTrue = -1
Const TristateUseDefault = -2

On Error Resume Next

If Not IsArray( arrayCode ) Then
arrayCode = Array( arrayCode )
End If

For i = 0 To UBound( arrayCode )
If Not IsNumeric( arrayCode(i) ) Then
Encode = 1032
Exit Function
End If
If arrayCode(i) < 0 Or arrayCode(i) > 255 Then
Encode = 1031
Exit Function
End If
Next

Set objFSO = CreateObject( "Scripting.FileSystemObject" )

If objFSO.FileExists( myFileIn ) Then
Set objFileIn = objFSO.GetFile( myFileIn )
Set objStreamIn = objFileIn.OpenAsTextStream( ForReading, TriStateFalse )
Else
Encode = 53
objStreamIn.Close
Set objStreamIn = Nothing
Set objFileIn = Nothing
Set objFSO = Nothing
Exit Function
End If

If objFSO.FileExists( myFileOut ) Then
Encode = 58
objStreamIn.Close
Set objStreamIn = Nothing
Set objFileIn = Nothing
Set objFSO = Nothing
Exit Function
Else
Set objFileOut = objFSO.CreateTextFile( myFileOut, True, False )
End If

i = 0
Do Until objStreamIn.AtEndOfStream
i = ( i + 1 ) \ ( UBound( arrayCode ) + 1 )
objFileOut.Write Chr( Asc( objStreamIn.Read( 1 ) ) Xor arrayCode(i) )
Loop

objFileOut.Close
objStreamIn.Close
Set objStreamIn = Nothing
Set objFileIn = Nothing
Set objFileOut = Nothing
Set objFSO = Nothing

Encode = Err.Number

Err.Clear
On Error Goto 0
End Function

Function ReturnKey( encryptionCode )
Dim i, arrayCode( )
ReDim arrayCode( Len( encryptionCode ) - 1 )
For i = 0 To UBound( arrayCode )
arrayCode(i) = Asc( Mid( encryptionCode, i + 1, 1 ) )
Next
ReturnKey = arrayCode
End Function