还是半自动版:
在后台监视到新链接后报警,并启动IE,验证码必须手动输入,其它的当然也可以自己输入,完后得自己手动提交。
抢不抢得到沙发不一定,但相信在一般情况下绝对能出现在留言首页:)- Option Explicit
-
- Dim sFile, iInterval, sLink
- sFile = "link.wri" 'where the last link is saved
- iInterval = 30 'how many seconds between twice check
-
- ShowUsage
- Do
- sLink = GetLink(sFile)
- CheckLink sLink, iInterval
- OpenLink sLink
- PutLink sFile, sLink
- PlaySound
- InputBox "The blog has updated!", "Information", sLink
- Loop
-
-
-
- Sub ShowUsage()
- MsgBox _
- " Run the tool and never kill its process unless " & "you indeed know what you're doing. " & vbCrLf & _
- " When the tool finds that the blog has updated, it'll pop up an IE window which display " & vbCrLf & _
- "the right new blog, in which you can reply after inputing some messages." & vbCrLf & _
- " Almost at the same time, it'll start to alarm for a few seconds. " & vbCrLf & _
- " Then an input box will appear, where you can copy the new link and which will also attract " & vbCrLf & _
- "your attention to tell you a new blog has been born." & vbCrLf & _
- " After you close the input box, it'll continue to monitor." & vbCrLf & _
- " So if you'd like to stop it, you'll have to kill its process named wscript.exe." & vbCrLf & vbCrLf & vbCrLf & _
- " Have a good time!", _
- _
- vbInformation, _
- _
- "by youxi01, everest79, pusofalse, rat & other guys@bbs.bathome.net 2008-11-21 19:22"
- End Sub
-
- Function GetLink(sFile)
- Const LINK = "http://blog.sina.com.cn/s/blog_49aaa3430100c9od.html", READ = 1
- Dim oFso, oFile
- Set oFso = CreateObject("Scripting.FileSystemObject")
-
- If Not oFso.FileExists(sFile) Then
- PutLink sFile, LINK
- GetLink = LINK
- Else
- Set oFile = oFso.OpenTextFile(sFile, READ, False)
- GetLink = oFile.ReadLine()
- oFile.Close
- Set oFile = Nothing
- End If
-
- Set oFso = Nothing
- End Function
-
- Sub CheckLink(sLink, iInterval) 'idea from everest79
- Const URL = "http://blog.sina.com.cn/rss/shuchang.xml", COMPLETE = 4
- Dim oXmlHttp, sNewLink
- Set oXmlHttp = CreateObject("Msxml2.XMLHTTP")
-
- Do
- oXmlHttp.open "Get", URL, False
- oXmlHttp.send
- sNewLink = oXmlHttp.responseXML _
- .selectSingleNode("rss") _
- .selectSingleNode("channel") _
- .selectSingleNode("item") _
- .selectSingleNode("link") _
- .text
- Do Until oXmlHttp.readyState = COMPLETE
- WScript.Sleep 100
- Loop
- If sNewLink <> sLink Then
- sLink = sNewLink 'ByRef by default
- Exit Do
- Else
- WScript.Sleep iInterval * 1000
- End If
- Loop
-
- Set oXmlHttp = Nothing
- End Sub
-
- Sub OpenLink(sLink)
- Const COMPLETE = 4, _
- NAME = "bbs.bathome.net", _
- COMMENT = "We love you forever!", _
- BBS = "http://bbs.bathome.net/thread-2465-1-1.html"
- Dim oIE, oDocument, oWindow
- Set oIE = CreateObject("InternetExplorer.Application")
-
- oIE.Navigate sLink
- Do While (oIE.Busy Or (oIE.ReadyState <> COMPLETE))
- WScript.Sleep 100
- Loop
-
- Set oDocument = oIE.Document
- oDocument.All("anonymity_name").Value = NAME
- oDocument.All("commentArea").Value = COMMENT & vbCrLf & vbCrLf & BBS
- oDocument.All("anonymity").Checked = True
- oDocument.All("login_check").Click
- oDocument.All("comment_post_btn").InsertAdjacentHTML "AfterEnd", _
- "<div align=""right"">" & _
- "<a target=""_blank"" href=""" & BBS & """>The topic about the tool...</a>" & _
- "</div>"
-
- Set oWindow = oDocument.ParentWindow
- 'oWindow.ReSizeTo oScreen.Width, oScreen.Height
- 'oWindow.MoveTo 0, 0
- oWindow.Scroll 0, oIE.Document.Body.ScrollHeight 'idea from everest79
- 'It doesn't scroll to the bottom, why?
- 'And if there is a MsgBox before it, it seems as if it'll work...
-
- oIE.Visible = True
- 'oIE.Quit 'wait for inputting validation code
-
- Set oWindow = Nothing
- Set oDocument = Nothing
- Set oIE = Nothing
- End Sub
-
- Sub PutLink(sFile, sLink)
- Const WRITE = 2
- Dim oFso, oFile
- Set oFso = CreateObject("Scripting.FileSystemObject")
- Set oFile = oFso.OpenTextFile(sFile, WRITE, True)
-
- oFile.WriteLine sLink
-
- oFile.Close
- Set oFile = Nothing
- Set oFso = Nothing
- End Sub
-
- Sub PlaySound()
- Dim oWsh
- Set oWsh = CreateObject("WScript.Shell")
-
- oWsh.Run "mplay32 /play /close %SystemRoot%\Clock.avi", 0, True
-
- Set oWsh = Nothing
- End Sub
复制代码
|