ENCRIPSI RC4

 This code offers you a strong encryption
with RC4. I've tested it a lot and it's the right
implementation of the RC4 cipher. 'You can use
this code in your commercial code because it's
not patented! 'I know there is another code that
deals with RC4 but my code has nothing to do with
this code!

Copy coding dibawah ini dan paste di Editor Form:

'**************************************
' Name: (Update) RC4 Stream Cipher (with
'     file handling )
' Description:This code offers you a str
'     ong encryption with RC4. I've tested it 
'     a lot and it's the right implementation 
'     of the RC4 cipher.
'You can use this code in your commercia
'     l code because it's not patented!
'I know there is another code that deals

'     with RC4 but my code has nothing to do w
    '     ith this code! 
    'More infos: sci.crypt
' By: Sebastian
'
' Inputs:Create the form and simply sele
'     ct a file to en(de)crypt!
'Notice that you use the same function f
'     or encryption and decryption
'
' Returns:After you press the Button you
'     should get the en(de)crypted file!
'
' Assumes:'Assumes:Create a form with:
'
'txtpwd (txtbox)
'txtSave (txtbox)
'txtPattern (Combobox)
'filList (FileListBox)
'DirList (DirListBox)
'drvList (DrvlistBox)
'Command1 (Command Button ; Caption=Encr
'     ypt)
'Command2 (Command Button ; Caption=Decr
'     ypt)
'
' Side Effects:If you encrypt different 
'     textes with the same password, someone c
'     ould be able to decrypt your code. (This
'     is quiet normal for a stream cipher!)
If YOU ENCRYPT LARGE FILES PLEASE USE THE EnDeCryptSingle ROUTINE INSTEAD OF THE EnDeCrypt ROUTINE OR SPLIT THE INPUT IN SMALLER PIECES!
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=1736&lngWId=1'for details.'**************************************

Option Explicit
Dim s(0 To 255) As Integer 'S-Box
Dim kep(0 To 255) As Integer
Dim i As Integer, j As Integer
'For the file actions
Dim path As String

Public Sub RC4ini(Pwd As String)

    Dim temp As Integer, a As Integer, b As Integer
    'Save Password in Byte-Array
    b = 0


    For a = 0 To 255
        b = b + 1


        If b > Len(Pwd) Then
            b = 1
        End If

        kep(a) = Asc(Mid$(Pwd, b, 1))
    Next a

    'INI S-Box

    For a = 0 To 255
        s(a) = a
    Next a

    b = 0


    For a = 0 To 255
        b = (b + s(a) + kep(a)) Mod 256
        ' Swap( S(i),S(j) )
        temp = s(a)
        s(a) = s(b)
        s(b) = temp
    Next a

End Sub

'Only use this routine for short texts

Public Function EnDeCrypt(plaintxt As Variant) As Variant

    Dim temp As Integer, a As Long, i As Integer, j As Integer, k As Integer
    Dim cipherby As Byte, cipher As Variant

    For a = 1 To Len(plaintxt)
        i = (i + 1) Mod 256
        j = (j + s(i)) Mod 256
        ' Swap( S(i),S(j) )
        temp = s(i)
        s(i) = s(j)
        s(j) = temp
        'Generate Keybyte k
        k = s((s(i) + s(j)) Mod 256)
        'Plaintextbyte xor Keybyte
        cipherby = Asc(Mid$(plaintxt, a, 1)) Xor k
        cipher = cipher & Chr(cipherby)
    Next a

    EnDeCrypt = cipher
End Function

'Use this routine for really huge files

Public Function EnDeCryptSingle(plainbyte As Byte) As Byte

    Dim temp As Integer, k As Integer
    Dim cipherby As Byte
    i = (i + 1) Mod 256
    j = (j + s(i)) Mod 256
    ' Swap( S(i),S(j) )
    temp = s(i)
    s(i) = s(j)
    s(j) = temp
    'Generate Keybyte k
    k = s((s(i) + s(j)) Mod 256)
    'Plaintextbyte xor Keybyte
    cipherby = plainbyte Xor k
    EnDeCryptSingle = cipherby
End Function

'************This section handles the fi
'     le actions*****************

Private Sub DirList_Change()

    filList.path = Dirlist.path
End Sub


Private Sub drvList_Change()

    On Error Goto DriveHandler
    Dirlist.path = drvList.Drive
    Exit Sub
    DriveHandler:
    drvList.Drive = Dirlist.path
    Exit Sub
End Sub


Private Sub filList_Click()

    txtSave.Text = filList.List(filList.ListIndex)
End Sub


Private Sub Form_Load()

    txtPatter.AddItem "*.*", 0
    txtPatter.AddItem "*.txt", 1
    filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Change()

    filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Click()

    filList.Pattern = txtPatter.Text
End Sub

'************* Encrypten Routine *******
'     ***********

Private Sub Command1_Click()

    Dim inbyte As Byte
    Dim z As Long
    'Set the Set-Box Counter zero
    i = 0: j = 0
    'Ini the S-Boxes only once for a hole fi
    '     le

    If txtpwd.Text = "" Then
        MsgBox "You need To enter a password For encrypten or decrypten"
        Exit Sub
    Else
        RC4ini (txtpwd.Text)
    End If

    'Disable the Mousepointer
    MousePointer = vbHourglass
    path = Dirlist.path + "\" + txtSave
    Open path For Binary As 1
    Open path + ".enc" For Binary As 2


    For z = 1 To LOF(1)
        Get #1, , inbyte
        Put #2, , EnDeCryptSingle(inbyte)
    Next z

    Close 1
    Close 2
    'Enable the Mousepointer
    MousePointer = vbDefault
End Sub

'*********** Decryptenroutine **********
'     *

Private Sub Command2_Click()

    Dim inbyte As Byte
    Dim z As Long
    'Set the Set-Box counter zero
    i = 0: j = 0
    'Ini the S-Boxes only once for a hole fi
    '     le

    If txtpwd.Text = "" Then
        MsgBox "You need To enter a password For encrypten or decrypten"
        Exit Sub
    Else
        RC4ini (txtpwd.Text)
    End If

    'Disable the Mousepointer
    MousePointer = vbHourglass
    path = Dirlist.path + "\" + txtSave
    Open path For Binary As 1
    path = Left$(path, Len(path) - 4)
    Open path For Binary As 2


    For z = 1 To LOF(1)
        Get #1, , inbyte
        Put #2, , EnDeCryptSingle(inbyte)
    Next

    Close 1
    Close 2
    'Enable the Mousepointer
    MousePointer = vbDefault
End Sub