'******************************************************************************* ' MODULE: modRC4 ' FILENAME: modRC4.bas ' AUTHOR: Jared De Blander ' CREATED: December 3, 2005 ' COPYRIGHT: Copyright (c) 2006 Jared De Blander. All Rights Reserved. ' WEBSITE: http://www.jx90.com/ ' E-MAIL: jared@deblander.org ' 'LICENSE: ' This library is free software; you can redistribute it and/or ' modify it under the terms of the GNU Lesser General Public ' License as published by the Free Software Foundation; either ' version 2.1 of the License, or (at your option) any later version. ' ' This library is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ' Lesser General Public License for more details. ' ' You should have received a copy of the GNU Lesser General Public ' License along with this library; if not, write to the Free Software ' Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ' ' DESCRIPTION: ' Based on the RC4 description found on WikiPedia. RC4Legacy yeilds same reults ' as RC4 but is significantly slower to run. As data sets grow using strings to ' to the data processing becomes slower exponentially. For example on an AMD ' Athlon 64 3000+ to do a 256KB block takes 58.57 seconds in legacy and 0.0439 ' using the new method. In the useage below getTimer is using the ' modHighResTimer module on http://www.jx90.com/source/ ' ' USEAGE: ' ' Private Sub Main() ' Dim d As String ' Dim k As String ' Dim s As Double ' Dim t As Double ' ' d = Space(CLng(1024) * CLng(256)) '256KB ' k = "my key" ' 'legacy ' s = getTimer ' d = RC4Legacy(d, k) ' t = getTimer ' MsgBox "Legacy: " & Format(t - s, "#0.0000") ' 'new ' s = getTimer ' d = RC4(d, k) ' t = getTimer ' MsgBox "New: " & Format(t - s, "#0.0000") ' 'verify ' d = "hello world" ' k = "my password" ' d = RC4Legacy(d, k) ' MsgBox "hello world encrypted with legacy = " & d ' d = RC4(d, k) ' MsgBox "hello world decrypted new = " & d ' End Sub ' 'MODIFICATION HISTORY: '12/6/2005 '1. Added file encryption. (RC4File) ' '12/3/2005 '1. Initial release. ' '******************************************************************************* Private RC4TmpByte As Byte Public Function RC4Legacy(dataIn As String, RC4Key As String) As String Dim s(255) As Byte Dim k(255) As Byte Dim I As Long Dim j As Long Dim p As Long Dim m As Long Dim lKeyLen As Long 'length of key Dim lDataLen As Long 'length of data j = 0 'set j to 0 lKeyLen = Len(RC4Key) 'length of the key lDataLen = Len(dataIn) 'length of the data If lKeyLen > 0 And lDataLen > 0 Then For I = 0 To 255 s(I) = I '0 to 255 k(I) = Asc(Mid(RC4Key, 1 + (I Mod lKeyLen), 1)) 'repeat key Next For I = 0 To 255 j = j + CLng(s(I)) j = j + CLng(k(I)) j = j Mod 256 RC4Swap s(I), s(j) 'swap Next I = 0 j = 0 RC4Legacy = "" For p = 1 To lDataLen I = I + 1 'increment i I = I Mod 256 'i = 0 to 255 j = j + CLng(s(I)) 'rotation position j = j Mod 256 'j = 0 to 255 RC4Swap s(I), s(j) 'swap positions t = CLng(s(I)) + CLng(s(j)) 'calculate t t = t Mod 256 't = 0 to 255 RC4Legacy = RC4Legacy & Chr(RC4Xor(s(t), Asc(Mid(dataIn, p, 1)))) Next End If End Function Public Function RC4(dataIn As String, RC4Key As String) As String Dim bDataIn() As Byte Dim bDataOut() As Byte Dim s(255) As Byte Dim k(255) As Byte Dim I As Long Dim j As Long Dim p As Long Dim m As Long Dim lKeyLen As Long 'length of key Dim lDataLen As Long 'length of data j = 0 'set j to 0 lKeyLen = Len(RC4Key) 'length of the key lDataLen = Len(dataIn) 'length of the data If lKeyLen > 0 And lDataLen > 0 Then bDataIn = StrConv(dataIn, vbFromUnicode) ReDim bDataOut(0 To UBound(bDataIn)) For I = 0 To 255 s(I) = I '0 to 255 k(I) = Asc(Mid(RC4Key, 1 + (I Mod lKeyLen), 1)) 'repeat key Next For I = 0 To 255 j = j + CLng(s(I)) j = j + CLng(k(I)) j = j Mod 256 RC4Swap s(I), s(j) 'swap Next I = 0 j = 0 lDataLen = lDataLen - 1 For p = 0 To lDataLen I = I + 1 'increment i I = I Mod 256 'i = 0 to 255 j = j + CLng(s(I)) 'rotation position j = j Mod 256 'j = 0 to 255 RC4Swap s(I), s(j) 'swap positions t = CLng(s(I)) + CLng(s(j)) 'calculate t t = t Mod 256 't = 0 to 255 bDataOut(p) = RC4Xor(s(t), bDataIn(p)) Next End If RC4 = StrConv(bDataOut, vbUnicode) End Function Public Function RC4File(theFileIn As String, theFileOut As String, RC4Key As String) As Long 'returns status code '0 = OK '1 = Input file not found '2 = Error reading input file '4 = Error creating output file '8 = key too short '16 = error closing input file '32 = error closing output file On Error Resume Next Dim bDataIn As Byte Dim s(255) As Byte Dim k(255) As Byte Dim I As Long Dim j As Long Dim p As Long Dim m As Long Dim FFIO1 As Long Dim FFIO2 As Long Dim lKeyLen As Long 'length of key Dim lDataLen As Long 'length of data j = 0 'set j to 0 RC4File = 0 'set OK If RC4FileExists(theFileIn) Then lKeyLen = Len(RC4Key) 'length of the key lDataLen = RC4FileLength(theFileIn) 'length of the data If lKeyLen > 0 And lDataLen > 0 Then For I = 0 To 255 s(I) = I '0 to 255 k(I) = Asc(Mid(RC4Key, 1 + (I Mod lKeyLen), 1)) 'repeat key Next For I = 0 To 255 j = j + CLng(s(I)) j = j + CLng(k(I)) j = j Mod 256 RC4Swap s(I), s(j) 'swap Next I = 0 j = 0 FFIO1 = FreeFile Open theFileIn For Binary As FFIO1 If Err Then Err.Clear RC4File = 2 Else FFIO2 = FreeFile Open theFileOut For Binary As FFIO2 If Err Then Err.Clear RC4File = 4 Else For p = 1 To lDataLen I = I + 1 'increment i I = I Mod 256 'i = 0 to 255 j = j + CLng(s(I)) 'rotation position j = j Mod 256 'j = 0 to 255 RC4Swap s(I), s(j) 'swap positions t = CLng(s(I)) + CLng(s(j)) 'calculate t t = t Mod 256 't = 0 to 255 Get FFIO1, p, bDataIn bDataIn = RC4Xor(s(t), bDataIn) Put FFIO2, p, bDataIn Next End If Close FFIO2 If Err Then Err.Clear RC4File = RC4File + 32 End If End If Close FFIO1 If Err Then Err.Clear RC4File = RC4File + 16 End If Else RC4File = 8 End If Else RC4File = 1 End If End Function Private Sub RC4Swap(ByRef Byte1 As Byte, ByRef Byte2 As Byte) RC4TmpByte = Byte1 Byte1 = Byte2 Byte2 = RC4TmpByte End Sub Private Function RC4Xor(Byte1 As Byte, Byte2 As Byte) As Byte If Byte1 = Byte2 Then RC4Xor = Byte1 Else RC4Xor = Byte1 Xor Byte2 End If End Function Private Function RC4FileExists(sFilePath As String) As Boolean 'checks if a file exists 'taken from modFileRoutines.bas. Copyright Jared De Blander 2005 'the alternate method is used to handle files that are 'located on network paths such as \\server123\folder\file.dat 'which return false when testing with the standard dir method. On Error Resume Next 'turn on error checking Dim FFIO As Long 'for alternate method RC4FileExists = (Dir(sFilePath) <> "") 'call file exists routine If Err Then 'error trap RC4FileExists = False 'set file does not exist Err.Clear 'clear error codes End If 'end error trap If Not RC4FileExists Then 'if false try another method FFIO = FreeFile 'get free file io address Open sFilePath For Input As FFIO 'attempt to open the file If Err Then 'if this results in error Err.Clear 'clear the error RC4FileExists = False 'assume the file does not exist Close FFIO 'attempt to close the file handle Err.Clear 'clear the error code Else 'otherwise RC4FileExists = True 'we can presume file exists on Close FFIO 'close the file handle If Err Then Err.Clear 'kill an error if it occured while closing End If 'a network drive End If 'done with alternate check End Function 'return to where we left off Private Function RC4FileLength(theFile As String) As Long 'return the size as a long (fixes broken FileLen XP SP2) 'taken from modFileRoutines.bas. Copyright Jared De Blander 2005 On Error Resume Next 'turn on error checking If Not RC4FileExists(theFile) Then 'if file doesn't exist RC4FileLength = 0 'return a 0 Else 'otherwise Dim tFF As Integer 'make room for a file handle tFF = FreeFile 'get a file handle Open theFile For Binary As tFF 'open the file If Err Then 'trap an error Err.Clear 'clear error code RC4FileLength = 0 'return a 0 Else 'otherwise RC4FileLength = LOF(tFF) 'get file length End If 'exit error trap Close tFF 'close file End If 'done End Function 'return to where we left off