某DZ论坛自动循环回帖VBS脚本

Dim url
url="https://www.wendangku.net/doc/3f14408367.html,/forum-59-2.html" '要回帖的版面地址
Do
GetUrl(url)
Loop While(ReadUrl)


Function GetUrl(url) '从输入的Url中取得所有的帖子地址存入D:\url.txt，如果取得的为空返回FALSE，如果不为空返回True
dim xp,MyStream,s'取网页源码
set xhp=createobject("MsXml2.XmlHttp")
xhp.open "get",url,false
xhp.send
Do Until xhp.readyState = 4
WScript.Sleep 200
Loop
WScript.Sleep 1000
s=xhp.ResponseText
Dim re,sMsg,mstr'取网址，用两次正则
Set re = New RegExp
re.Global = True
re.IgnoreCase=True
re.Pattern="thread-\d*-\d*-\d*\.html""\sonclick=""atarget\(this"
Set col= re.Execute(s)
re.Pattern="""\sonclick=""atarget\(this"
sMsg = ""
mstr=""
For Each m in col
mstr=re.Replace(m.Value,"") '区调后面定位的" onclick=" atarget\(this
sMsg = sMsg & "https://www.wendangku.net/doc/3f14408367.html,/" & mstr & vbCrLf
Next
dim fso,f '写入D:\url.txt
set fso = CreateObject("Scripting.FileSystemObject")
set f = fso.CreateTextFile("D:\url.txt", true)
f.Write(sMsg)
f.close
set f=Nothing
set fso=Nothing
if sMsg="" Then
GetUrl=False
Else
GetUrl=True
'MsgBox "获得帖子URl成功"
End If
End Function

Function ReadUrl'循环读取TXT文件中获得帖子的url，取完之后返回True
Dim fso,ts,s
set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile("D:\url.txt" , 1) 'url.txt 放在 D盘
Do Until ts.AtEndOfStream
s = ts.ReadLine
if len(s) > 1 then '非空行
url_tmp = Trim(s) '去两端空格
if IsSame(url_tmp) Then
'msgbox url_tmp
Recv_bbs(url_tmp)
WriteToTxt(url_tmp)
end if
end if
loop
ts.Close
set WshShell = nothing
set fso = nothing
set ts = nothing
ReadUrl=True
End Function

Function Recv_bbs(murl) '打开IE回帖
Dim s,IE,shl
s=murl
set IE = CreateObject("InternetExplorer.Application")
IE.Navigate2 s
IE.Visible = True
WScript.Sleep 30000
IE.Document.GetElementById("fastpostmessage").innerHTML = "自损超过800，唉，不提了，都是眼泪。仅有的两个玩家队友很难掌控局面，更多的是依靠器械和英魂的发挥"
WScript.Sleep 10000
IE.Document.getElementById("fastpostsubmit").click
WScript.Sleep 20000
set shl=wscript.createobject("wscript.shell")
shl.run "cmd.exe /c taskkill /f /im 360Se.exe"
set IE =Nothing
set shl=Nothing
End Function

Function WriteToTxt(murl)'回帖完的URL写入D:\done.txt文件
dim s,fso,f
s=murl
set fso = CreateObject("Scripting.FileSystemObject")
set f = fso.OpenTextFile("D:\done.txt",8, true)
f.WriteLine(s)
f.close
set f = nothing
set fso = nothing
End Function

Function IsSame(url)'判断url与D:\done.txt文件中的URL是否重复，重复返回False，不重复返回True
Set objFSO = CreateObject("Scripting.File

SystemObject")
Set objTextFile = objFSO.OpenTextFile("D:\done.txt" , 1)
Do Until objTextFile.AtEndOfStream
url_tmp1 = objTextFile.Readline
url_tmp1 = Trim(url_tmp1) '去两端空格
If url_tmp1 = url Then
IsSame = False
Exit Do
Else
IsSame = True
End If
Loop
objTextFile.Close
Set objFSO = Nothing
Set objTextFile =Nothing
End Function