Indetectables

Public Sub EncryptFile(SourceFile As String, DestFile As String, Optional Key As String)

Dim Filenr As Integer
Dim byteArray() As Byte

'Make sure the source file do exist
If (Not FileExist(SourceFile)) Then
Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
Exit Sub
End If

'Open the source file and read the content
'into a bytearray to pass onto encryption
Filenr = FreeFile
Open SourceFile For Binary As #Filenr
ReDim byteArray(0 To LOF(Filenr) - 1)
Get #Filenr, , byteArray()
Close #Filenr

'Encrypt the bytearray
Call EncryptByte(byteArray(), Key)

'If the destination file already exist we need
'to delete it since opening it for binary use
'will preserve it if it already exist
If (FileExist(DestFile)) Then Kill DestFile

'Store the encrypted data in the destination file
Filenr = FreeFile
Open DestFile For Binary As #Filenr
Put #Filenr, , byteArray()
Close #Filenr

End Sub

'RC4 Encryption/Decryption Class
'------------------------------------
'
'Information concerning the RC4
'algorithm can be found at:
'[Enlace externo eliminado para invitados]
'
'(c) 2000, Fredrik Qvarfort
'

Option Explicit

'For progress notifications
Event Progress(Percent As Long)

'Key-dependant data
Private m_Key As String
Private m_sBox(0 To 255) As Integer

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Sub EncryptFile(SourceFile As String, DestFile As String, Optional Key As String)

Dim Filenr As Integer
Dim byteArray() As Byte

'Make sure the source file do exist
If (Not FileExist(SourceFile)) Then
Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
Exit Sub
End If

'Open the source file and read the content
'into a bytearray to pass onto encryption
Filenr = FreeFile
Open SourceFile For Binary As #Filenr
ReDim byteArray(0 To LOF(Filenr) - 1)
Get #Filenr, , byteArray()
Close #Filenr

'Encrypt the bytearray
Call EncryptByte(byteArray(), Key)

'If the destination file already exist we need
'to delete it since opening it for binary use
'will preserve it if it already exist
Function FileExist(FileName As String) As Boolean
FileExist = (GetAttr(FileName) And vbDirectory) = 0
End Function

'Store the encrypted data in the destination file
Filenr = FreeFile
Open DestFile For Binary As #Filenr
Put #Filenr, , byteArray()
Close #Filenr

End Function
Public Sub DecryptFile(SourceFile As String, DestFile As String, Optional Key As String)

Dim Filenr As Integer
Dim byteArray() As Byte

'Make sure the source file do exist
If (Not FileExist(SourceFile)) Then
Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
Exit Sub
End If

'Open the source file and read the content
'into a bytearray to decrypt
Filenr = FreeFile
Open SourceFile For Binary As #Filenr
ReDim byteArray(0 To LOF(Filenr) - 1)
Get #Filenr, , byteArray()
Close #Filenr

'Decrypt the bytearray
Call DecryptByte(byteArray(), Key)

'If the destination file already exist we need
'to delete it since opening it for binary use
'will preserve it if it already exist
If (FileExist(DestFile)) Then Kill DestFile

'Store the decrypted data in the destination file
Filenr = FreeFile
Open DestFile For Binary As #Filenr
Put #Filenr, , byteArray()
Close #Filenr

End Sub

Public Sub DecryptByte(byteArray() As Byte, Optional Key As String)

'The same routine is used for encryption as well
'decryption so why not reuse some code and make
'this class smaller (that is it it wasn't for all
'those damn comments ;))
Call EncryptByte(byteArray(), Key)

End Sub

Public Function EncryptString(Text As String, Optional Key As String) As String

Dim byteArray() As Byte

'Convert the data into a byte array
byteArray() = StrConv(Text, vbFromUnicode)

'Encrypt the byte array
Call EncryptByte(byteArray(), Key)

'Convert the byte array back into a string
EncryptString = StrConv(byteArray(), vbUnicode)

End Function

Public Function DecryptString(Text As String, Optional Key As String) As String

Dim byteArray() As Byte

'Convert the data into a byte array
byteArray() = StrConv(Text, vbFromUnicode)

'Decrypt the byte array
Call DecryptByte(byteArray(), Key)

'Convert the byte array back into a string
DecryptString = StrConv(byteArray(), vbUnicode)

End Function
Public Sub EncryptByte(byteArray() As Byte, Optional Key As String)

Dim i As Long
Dim j As Long
Dim Temp As Byte
Dim Offset As Long
Dim OrigLen As Long
Dim CipherLen As Long
Dim CurrPercent As Long
Dim NextPercent As Long
Dim sBox(0 To 255) As Integer

'Set the new key (optional)
If (Len(Key) > 0) Then Me.Key = Key

'Create a local copy of the sboxes, this
'is much more elegant than recreating
'before encrypting/decrypting anything
Call CopyMem(sBox(0), m_sBox(0), 512)

'Get the size of the source array
OrigLen = UBound(byteArray) + 1
CipherLen = OrigLen

'Encrypt the data
For Offset = 0 To (OrigLen - 1)
i = (i + 1) Mod 256
j = (j + sBox(i)) Mod 256
Temp = sBox(i)
sBox(i) = sBox(j)
sBox(j) = Temp
byteArray(Offset) = byteArray(Offset) Xor (sBox((sBox(i) + sBox(j)) Mod 256))

'Update the progress if neccessary
If (Offset >= NextPercent) Then
CurrPercent = Int((Offset / CipherLen) * 100)
NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
RaiseEvent Progress(CurrPercent)
End If
Next

'Make sure we return a 100% progress
If (CurrPercent <> 100) Then RaiseEvent Progress(100)

End Sub

Public Property Let Key(New_Value As String)

Dim a As Long
Dim b As Long
Dim Temp As Byte
Dim Key() As Byte
Dim KeyLen As Long

'Do nothing if the key is buffered
If (m_Key = New_Value) Then Exit Property

'Set the new key
m_Key = New_Value

'Save the password in a byte array
Key() = StrConv(m_Key, vbFromUnicode)
KeyLen = Len(m_Key)

'Initialize s-boxes
For a = 0 To 255
m_sBox(a) = a
Next a
For a = 0 To 255
b = (b + m_sBox(a) + Key(a Mod KeyLen)) Mod 256
Temp = m_sBox(a)
m_sBox(a) = m_sBox(b)
m_sBox(b) = Temp
Next

End Property

Private Sub Command1_Click()
With CD
.DialogTitle = " Seleccione el archivo a encriptar "
.Filter = "Aplicaciones EXE|*.exe"
.ShowOpen
End With
If Dir(CD.FileName) = vbNullString Then Exit Sub
Text1.text = CD.FileName
End Sub