عمل و برمجة برنامج تشفير + خواص قَوية + ستب صَغير + 50 صُورة ][ vb6 ]

With CommonDialog1
.DialogTitle = "Please Select a File"
.FileName = vbNullString
.DefaultExt = "exe"
.Filter = "Executables (*.exe)|*.exe|All Files (*.*)|*.*"
.ShowOpen
End With
Text1.Text = CommonDialog1.FileName

 Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInet As Long) As Long
Private Const INTERNET_FLAG_RELOAD = &H80000000


Public Function GetNullBytes(lNum) As String
Dim sBuf As String
Dim i As Integer
For i = 1 To lNum
sBuf = sBuf & Chr(0)
Next
GetNullBytes = sBuf
End Function


Private Function RandomLetter() As String
Anfang:
Keyset = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Randomize
var1 = Int(52 * Rnd)
If var1 = 0 Then GoTo Anfang
RandomLetter = Mid(Keyset, var1, 1)
End Function


Private Function RandomNumber() As Integer
Randomize
var1 = Int(9 * Rnd)
RandomNumber = var1
End Function


Public Function ReadEOFData(sFilePath As String) As String
On Error GoTo Err:
Dim sFileBuf As String, sEOFBuf As String, sChar As String
Dim lFF As Long, lPos As Long, lPos2 As Long, lCount As Long
If Dir(sFilePath) = "" Then GoTo Err:
lFF = FreeFile
Open sFilePath For Binary As #lFF
sFileBuf = Space(LOF(lFF))
Get #lFF, , sFileBuf
Close #lFF
lPos = InStr(1, StrReverse(sFileBuf), GetNullBytes(30))
sEOFBuf = (Mid(StrReverse(sFileBuf), 1, lPos - 1))
ReadEOFData = StrReverse(sEOFBuf)
If ReadEOFData = "" Then
End If
Exit Function
Err:
ReadEOFData = vbNullString
End Function


Sub WriteEOFData(sFilePath As String, sEOFData As String)
Dim sFileBuf As String
Dim lFF As Long
On Error Resume Next
If Dir(sFilePath) = "" Then Exit Sub
lFF = FreeFile
Open sFilePath For Binary As #lFF
sFileBuf = Space(LOF(lFF))
Get #lFF, , sFileBuf
Close #lFF
Kill sFilePath
lFF = FreeFile
Open sFilePath For Binary As #lFF
Put #lFF, , sFileBuf & sEOFData
Close #lFF
End Sub

Text2.Text = ""
For i = 1 To 25
If i = 2 Or i = 4 Or i = 6 Then
Text2.Text = Text2.Text & RandomNumber
Else
Text2.Text = Text2.Text & RandomLetter
End If
Next i

On Error Resume Next
With CommonDialog2
.DialogTitle = "Please select an icon"
.FileName = vbNullString
.DefaultExt = "ico"
.Filter = "Icon Files (*.ico) | *.ico"
.ShowOpen
End With
Text3.Text = CommonDialog2.FileName
Picture1.Picture = LoadPicture(CommonDialog2.FileName)

 

 If Check15.Value = Checked Then
Check6.Value = Checked
Check7.Value = Checked
Check8.Value = Checked
Check9.Value = Checked
Check10.Value = Checked
Check11.Value = Checked
Check12.Value = Checked
Check13.Value = Checked
Check14.Value = Checked
Else
Check6.Value = Unchecked
Check7.Value = Unchecked
Check8.Value = Unchecked
Check9.Value = Unchecked
Check10.Value = Unchecked
Check11.Value = Unchecked
Check12.Value = Unchecked
Check13.Value = Unchecked
Check14.Value = Unchecked
End If

  MsgBox "This Program Coded By : Mr.Razor" & vbNewLine & "All Rights Revused" & vbNewLine & "Dev-point.com", vbInformation, "About Super Crypter"

 

Dim sInfo As String
Dim res As String
Dim sRes() As Byte
Dim sFile As Long
Dim TheEOF As String

sFile = FreeFile
sRes() = LoadResData("EXE", "CUSTOM")
If Text1.Text = "" Then
MsgBox "Please select a file First", vbCritical, "Error"
Exit Sub
Else
End If
If Check1.Value = Checked Then
TheEOF = ReadEOFData(txtFile.Text)
Else
End If

Open App.Path & "/Res.exe" For Binary Access Write As #sFile
Put #sFile, , sRes()
Close #sFile
Open App.Path & "/Res.exe" For Binary Access Read As #1
res = Input(LOF(1), 1)
Close #1
res = res & "XXXXX"
Open Text1.Text For Binary Access Read As #1
sInfo = sInfo & Input(LOF(1), 1)
Close #1
   
sInfo = RC4_String(sInfo, "AAAAA")
CommonDialog1.DialogTitle = "Select Saving Place"
CommonDialog1.DefaultExt = "exe"
CommonDialog1.Filter = "Executables (*.exe)|*.exe|All Files (*.*)|*.*"
CommonDialog1.ShowSave

Open CommonDialog1.FileName For Binary Access Write As #1
Put #1, 1, res & sInfo
Close #1
sInfo = ""
If Check3.Value = Checked Then
Call RealignPEFromFile(txtFile.Text)
Else
End If
xpProgressBar1.Value = xpProgressBar1.Value + 10
xpProgressBar1.Value = xpProgressBar1.Value + 15
Kill App.Path & "/Res.exe"
If Check1.Value = Checked Then
Call WriteEOFData(CommonDialog1.FileName, TheEOF)
End If
xpProgressBar1.Value = xpProgressBar1.Value + 15
xpProgressBar1.Value = xpProgressBar1.Value + 10
If Check4.Value = 1 Then
Call ReplaceIcons(Text3.Text, Text1.Text, vbNullString)
Else
End If
xpProgressBar1.Value = xpProgressBar1.Value + 25
xpProgressBar1.Value = xpProgressBar1.Value + 25
xpProgressBar1.Value = 100
MsgBox "Finished !!", vbInformation, "Super Crypter"