[讨论]VBS抢占舒畅博客的沙发

rat

具体你怎么实现可要贴代码上来

嘿嘿，一定一定

rat

又更新了，又没抢到……比沙发慢了2分钟…………………………

要是随便回复的话，可能要快点的。

pusofalse

粗略地用send发送键实现了回帖，但成功率不高~
不知rat兄注意到没有，在没有发表新回复之前，每篇文章的验证码都是一样的，包括其后发表的新日志，验证码也是同样的。可否先从旧的文章中，手动将验证码写入到文件呢。当检测到新链接时再从文件读取。

[ 本帖最后由 pusofalse 于 2008-11-16 11:49 编辑 ]

rat

原帖由 pusofalse 于 2008-11-16 11:42 发表
在没有发表新回复之前，每篇文章的验证码都是一样的，包括其后发表的新日志，验证码也是同样的。

不会是真的吧？

everest79

我觉得要弄这个，最好是用dhtml，用框架，上边显示操作，下边显示引用网页，这样所有的对象都是在一个window的子window中，处理起来也蛮方便，设想，没去试

rat

还是半自动版：
在后台监视到新链接后报警，并启动IE，验证码必须手动输入，其它的当然也可以自己输入，完后得自己手动提交。
抢不抢得到沙发不一定，但相信在一般情况下绝对能出现在留言首页：）

1. Option Explicit
   
2. 
   
3. Dim sFile, iInterval, sLink
   
4. sFile = "link.wri"        'where the last link is saved
   
5. iInterval = 30        'how many seconds between twice check
   
6. 
   
7. ShowUsage
   
8. Do
   
9.         sLink = GetLink(sFile)
   
10.         CheckLink sLink, iInterval
    
11.         OpenLink sLink
    
12.         PutLink sFile, sLink
    
13.         PlaySound
    
14.         InputBox "The blog has updated!", "Information", sLink
    
15. Loop
    
16. 
    
17. 
    
18. 
    
19. Sub ShowUsage()
    
20.         MsgBox _
    
21.                 "        Run the tool and never kill its process unless " & "you indeed know what you're doing. " & vbCrLf & _
    
22.                 "        When the tool finds that the blog has updated, it'll pop up an IE window which display " & vbCrLf & _
    
23.                 "the right new blog, in which you can reply after inputing some messages." & vbCrLf & _
    
24.                 "        Almost at the same time, it'll start to alarm for a few seconds. " & vbCrLf & _
    
25.                 "        Then an input box will appear, where you can copy the new link and which will also attract " & vbCrLf & _
    
26.                 "your attention to tell you a new blog has been born." & vbCrLf & _
    
27.                 "        After you close the input box, it'll continue to monitor." & vbCrLf & _
    
28.                 "        So if you'd like to stop it, you'll have to kill its process named wscript.exe." & vbCrLf & vbCrLf & vbCrLf & _
    
29.                 "        Have a good time!", _
    
30.                  _
    
31.                 vbInformation, _
    
32.                  _
    
33.                 "by youxi01, everest79, pusofalse, rat & other guys@bbs.bathome.net 2008-11-21 19:22"
    
34. End Sub
    
35. 
    
36. Function GetLink(sFile)
    
37.         Const LINK = "http://blog.sina.com.cn/s/blog_49aaa3430100c9od.html", READ = 1
    
38.         Dim oFso, oFile
    
39.         Set oFso = CreateObject("Scripting.FileSystemObject")
    
40.        
    
41.         If Not oFso.FileExists(sFile) Then
    
42.                 PutLink sFile, LINK
    
43.                 GetLink = LINK
    
44.         Else
    
45.                 Set oFile = oFso.OpenTextFile(sFile, READ, False)
    
46.                 GetLink = oFile.ReadLine()
    
47.                 oFile.Close
    
48.                 Set oFile = Nothing       
    
49.         End If
    
50.        
    
51.         Set oFso = Nothing
    
52. End Function
    
53. 
    
54. Sub CheckLink(sLink, iInterval)        'idea from everest79
    
55.         Const URL = "http://blog.sina.com.cn/rss/shuchang.xml", COMPLETE = 4
    
56.         Dim oXmlHttp, sNewLink
    
57.         Set oXmlHttp = CreateObject("Msxml2.XMLHTTP")
    
58.        
    
59.         Do
    
60.                 oXmlHttp.open "Get", URL, False
    
61.                 oXmlHttp.send
    
62.                 sNewLink = oXmlHttp.responseXML _
    
63.                         .selectSingleNode("rss") _
    
64.                         .selectSingleNode("channel") _
    
65.                         .selectSingleNode("item") _
    
66.                         .selectSingleNode("link") _
    
67.                         .text
    
68.                 Do Until oXmlHttp.readyState = COMPLETE
    
69.                         WScript.Sleep 100
    
70.                 Loop
    
71.                 If sNewLink <> sLink Then
    
72.                         sLink = sNewLink        'ByRef by default
    
73.                         Exit Do
    
74.                 Else
    
75.                         WScript.Sleep iInterval * 1000
    
76.                 End If
    
77.         Loop
    
78.        
    
79.         Set oXmlHttp = Nothing
    
80. End Sub
    
81. 
    
82. Sub OpenLink(sLink)
    
83.         Const COMPLETE = 4, _
    
84.                 NAME = "bbs.bathome.net", _
    
85.                 COMMENT = "We love you forever!", _
    
86.                 BBS = "http://bbs.bathome.net/thread-2465-1-1.html"
    
87.         Dim oIE, oDocument, oWindow
    
88.         Set oIE = CreateObject("InternetExplorer.Application")
    
89.        
    
90.         oIE.Navigate sLink
    
91.         Do While (oIE.Busy Or (oIE.ReadyState <> COMPLETE))
    
92.                 WScript.Sleep 100
    
93.         Loop
    
94.        
    
95.         Set oDocument = oIE.Document
    
96.         oDocument.All("anonymity_name").Value = NAME
    
97.         oDocument.All("commentArea").Value = COMMENT & vbCrLf & vbCrLf & BBS
    
98.         oDocument.All("anonymity").Checked = True
    
99.         oDocument.All("login_check").Click
    
100.         oDocument.All("comment_post_btn").InsertAdjacentHTML "AfterEnd", _
     
101.                 "<div align=""right"">" & _
     
102.                         "<a target=""_blank"" href=""" & BBS & """>The topic about the tool...</a>" & _
     
103.                 "</div>"
     
104.        
     
105.         Set oWindow = oDocument.ParentWindow
     
106.         'oWindow.ReSizeTo oScreen.Width, oScreen.Height
     
107.         'oWindow.MoveTo 0, 0
     
108.         oWindow.Scroll 0, oIE.Document.Body.ScrollHeight                'idea from everest79
     
109.                 'It doesn't scroll to the bottom, why?
     
110.                 'And if there is a MsgBox before it, it seems as if it'll work...
     
111.        
     
112.         oIE.Visible = True
     
113.         'oIE.Quit        'wait for inputting validation code
     
114.        
     
115.         Set oWindow = Nothing
     
116.         Set oDocument = Nothing
     
117.         Set oIE = Nothing
     
118. End Sub
     
119. 
     
120. Sub PutLink(sFile, sLink)
     
121.         Const WRITE = 2
     
122.         Dim oFso, oFile
     
123.         Set oFso = CreateObject("Scripting.FileSystemObject")
     
124.         Set oFile = oFso.OpenTextFile(sFile, WRITE, True)
     
125.        
     
126.         oFile.WriteLine sLink
     
127.        
     
128.         oFile.Close
     
129.         Set oFile = Nothing
     
130.         Set oFso = Nothing       
     
131. End Sub
     
132. 
     
133. Sub PlaySound()
     
134.         Dim oWsh
     
135.         Set oWsh = CreateObject("WScript.Shell")
     
136.        
     
137.         oWsh.Run "mplay32 /play /close %SystemRoot%\Clock.avi", 0, True
     
138.        
     
139.         Set oWsh = Nothing
     
140. End Sub

复制代码

everest79

刚刚创建的blog，通过对rat脚本的学习，终于搞懂了如何获取特定标签内容
参考内容：
http://www.w3school.com.cn/x.asp
http://blog.csdn.net/wf520pb/archive/2008/07/12/2644549.aspx

1. Const RSSPath="http://blog.sina.com.cn/rss/everest79.xml"
   
2. Dim Xml
   
3. Set Xml=CreateObject("Msxml2.XMLHTTP")
   
4. Xml.Open "Get",RSSPath,Fasle
   
5. Xml.Send
   
6. 'SelectSingleNode只返回符合路径的第一个结果
   
7. msgbox Xml.ResponseXML.SelectSingleNode("/rss/channel/item/link").Text
   
8. 
   
9. 'getElementsByTagName返会所有包含"title"节点的集合，需要枚举
   
10. For Each x In Xml.ResponseXML.getElementsByTagName("title")
    
11. Msgbox x.Text
    
12. Next
    
13. 
    
14. 'SelectNodes类似于getElemnetByTagName，但可以指定路径
    
15. For Each x In Xml.ResponseXML.SelectNodes("/rss/channel/item/link")
    
16. Msgbox x.Text
    
17. Next

复制代码

everest79

学习作品，发现新浪的验证码是根据进程变化的，所以就先填验证码，要是发现有新贴就自动发贴了，没用记录文件，写注册表里了，循环还不完善

1. Const REGPath="HKCU\Software\ScriptAuto\Temp"
   
2. Const RSSPath="http://blog.sina.com.cn/rss/everest79.xml"
   
3. Const Checkwd="http://vlogin.blog.sina.com.cn/myblog/checkwd_image.php"
   
4. Const iInterval=30
   
5. 
   
6. 
   
7. Dim Wsh,Xml,oIe,CheckID,oLink
   
8. Set Wsh=CreateObject("WScript.Shell")
   
9. Set Xml=CreateObject("Msxml2.XMLHTTP")
   
10. 
    
11. 
    
12. Do While True
    
13. Set oIe=CreateObject("InternetExplorer.Application")
    
14. CheckIN
    
15. oLink=sRunLog
    
16. CheckLinks
    
17. PostLink GetXmlLink
    
18. WScript.Sleep 10000
    
19. oIe.Quit
    
20. Set oIe=Nothing
    
21. WScript.Sleep 10000
    
22. Loop
    
23. 
    
24. Sub CheckIN
    
25. oIe.Navigate Checkwd
    
26. oIe.Visible=1
    
27. CheckID=Inputbox("请输入验证码!","BatHome 2008") '验证码是针对进程变化的，相同进程验证码相同，几小
    
28. oIe.Visible=0
    
29. End Sub
    
30. 
    
31. Function sRunLog
    
32. On Error Resume Next
    
33. Do
    
34. If Err.Number <> 0 Then
    
35. Wsh.RegWrite REGPath,GetXmlLink
    
36. Err.Clear
    
37. End If
    
38. sRunLog=Wsh.RegRead(REGPath)
    
39. Loop While Err.Number <> 0
    
40. End Function
    
41. 
    
42. Sub CheckLinks
    
43. Do While StrComp(oLink,GetXmlLink,1) = 0
    
44. WScript.Sleep iInterval*1000
    
45. Loop
    
46. End Sub
    
47. 
    
48. Sub PostLink(nLink)
    
49. With oIe
    
50. .Navigate nLink
    
51. Do While .Busy Or .ReadyState <> 4
    
52. WScript.Sleep 500
    
53. Loop
    
54. .Document.All("anonymity_name").Value="性浪"
    
55. .Document.All("commentArea").Value="好大的一根毛呀"
    
56. .Document.All("anonymity").Checked=True
    
57. .Document.All("login_check").Value=CheckID
    
58. '.Document.All("modifyTitle").Href="#post"
    
59. 'WScript.Sleep 1000
    
60. '.Document.All("modifyTitle").Click
    
61. .Document.All("comment_post_btn").Click
    
62. End With
    
63. Wsh.RegWrite REGPath,nLink
    
64. End Sub
    
65. 
    
66. Function GetXmlLink
    
67. Xml.Open "Get",RSSPath,Fasle
    
68. Xml.Send
    
69. GetXmlLink=Xml.ResponseXML.SelectSingleNode("/rss/channel/item/link").Text
    
70. End Function

复制代码

rat

去了临时文件，全自动回复，很好！

不过还有小问题：我这边测试执行完CheckIN后，好像oIe就没了，总是提示什么已与客户断开连接。
对了，执行oIe.Navigate Checkwd 时，我这儿是提示下载图片。（XP Home + IE6）

还有，根据进程变化是什么意思呢？我好像多次运行此vbs脚本得到的验证码都是一样的。

everest79

出现下载图片是IE的问题，有些IE扩展组件没有激活，好像是什么补丁，不过可以通过打开空白页，然后写入<IMG SRC=Checkwd>这样来显示图片

这个验证码在同一进程下不会变化，最长是多长时间还不清楚，例如你PID为228的进程创建了显示图片的网页，那在PID228下的所有IE线程请求这个页面得到的验证码都是一样的，刷新只是字体变化

pusofalse

1. #Include <IE.Au3>
   
2. Opt("ExpandEnvStrings", 1)
   
3. If FileExists("%Temp%\Verify.jpg") Then FileDelete("%Temp%\Verify.jpg")
   
4. ;http://blog.sina.com.cn/s/blog_49aaa3430100cep9.html
   
5. Global $Ie = _IECreate("Http://blog.sina.com.cn/shuchang", 0, 0, 1)
   
6. ;===================Get New Link.=================
   
7. $Links = _IELinkGetCollection($Ie)
   
8. $Suffix = "^http://blog.sina.com.cn/s/blog_49aaa(?i)[a-z0-9]+\.html$"
   
9. For $ele In $Links
   
10. $CorrectLink = StringRegExp($ele.href, $Suffix, 1)
    
11. If IsArray($CorrectLink) Then
    
12.   $Flag1 = 1
    
13.   ExitLoop
    
14. EndIf
    
15. Next
    
16. If Not IsDeclared("Flag1") Then
    
17. _IEQuit($Ie)
    
18. MsgBox(16, "Error:", "出错了！~~~")
    
19. Exit(-1)
    
20. ElseIf Not FileExists("s.x") Then
    
21. _IEQuit($Ie)
    
22. FileWrite("s.x", $CorrectLink[0])
    
23. Exit(0)
    
24. ElseIf FileRead("s.x") <> $CorrectLink[0] Then
    
25. _GetVerifyImg($CorrectLink[0])
    
26. Else
    
27. Exit(0)
    
28. EndIf
    
29. ;===================Get New Link.=================
    
30. ;================Get Verifier Image=================
    
31. Func _GetVerifyImg($Link)
    
32. _IENavigate($Ie, $Link)
    
33. _IELoadwait($Ie)
    
34. _IEAction($Ie, "visible")
    
35. $Images = _IEImgGetCollection($Ie)
    
36. $CheckWd = "^(?i)Http://vlogin.blog.sina.com.cn/myblog/checkwd_image.php$"
    
37. For $ele In $Images
    
38.   $Error = StringRegExp($ele.src, $CheckWd, 0)
    
39.   If $Error = 1 Then
    
40.    $Flag2 = 1
    
41.    InetGet($ele.src, @TempDir & "\Verify.jpg")
    
42.    Run("%ComSpec% /c start %Temp%\Verify.jpg", "", @SW_HIDE)
    
43.    ExitLoop
    
44.   EndIf
    
45. Next
    
46. If Not IsDeclared("Flag2") Then
    
47.   MsgBox(16, "Error:", "没有获取到验证码。")
    
48.   Exit(-2)
    
49. EndIf
    
50. _Post()
    
51. FileDelete(@TempDir & "\Verify.jpg")
    
52. EndFunc ;==> End GetVerifyImg().
    
53. ;================Get Verifier Image=================
    
54. ;======================Post=======================
    
55. Func _Post() ;Post
    
56. $Name = _IEGetObjByID($Ie, "login_name")
    
57. _IEPropertySet($Name, "InnerText", "pusofalse@sina.com")
    
58. $Pass = _IEGetObjByID($Ie, "login_pass")
    
59. _IEPropertySet($Pass, "InnerText", "purification")
    
60. $CommentArea = _IEGetObjByID($Ie, "CommentArea")
    
61. _IEPropertySet($CommentArea, "InnerText", "Happy!!!")
    
62. WinWait("Verify.jpg")
    
63. $VerifyCode = InputBox("Verify", "输入验证码：", "", "", "", "", 100, 200)
    
64. If Not $VerifyCode Then Exit(-1)
    
65. $Verify = _IEGetObjByID($Ie, "login_check")
    
66. _IEPropertySet($Verify, "InnerText", $VerifyCode)
    
67. $Submit = _IEGetObjByID($Ie, "comment_post_btn")
    
68. _IEAction($Submit, "click")
    
69. EndFunc ;==> End _Post().
    
70. ;======================Post=======================

复制代码

遇到了同样的问题，虽能获取到验证码，但成功率不高，50%左右吧。
测试程序在我的网盘里。

[ 本帖最后由 pusofalse 于 2008-11-25 00:54 编辑 ]

everest79

1. Do
   
2. Audio=.Document.parentWindow.ExecScript("callAudioCheck();","javascript")
   
3. CheckID=Inputbox("请输入验证码!","BatHome 2008")
   
4. Loop Whlie CheckID = ""

复制代码

这个方法可行，嘿嘿，一定不会错