超级军网茶馆专用穿小鞋器
来源：百度文库 编辑：超级军网 时间：2024/04/29 08:04:54
茶馆版规沦为废纸，法制成人治
有权者凭借自己爱恶，喜欢就任由其践踏版规，不喜欢就以版规穿小鞋－－锁－－沉－－删－－封－－
俺们萎缩捅PP一族一定要顺应形式才行。
特奉上一款，检查茶馆首页所有贴子的字数的脚本
运行后在后台自动检查不到500字违反版规的贴子，有违法者启动Ie直接转到该贴。
实为封帖灭口穿小鞋，举报捅PP砸砖头的好工具。
将下面代码copy笔记本，保存为xxx.vbs，点击运行。
'===================== 将下面代码copy笔记本，保存为xxx.vbs，点击运行。
Option Explicit
Const WEBSITE_URL="http://bbs.cjdby.net"
Const FORUM_INDEX_URL="http://bbs.cjdby.net/forumdisplay.php?fid=13"
Const TOPIC_BLOCK_DIVIDER="<td colspan=""4"">版块主题</td>"
Const TOPIC_A_PATTERN="<a href=""(viewthread\.php\?tid=\d+)[^""]*"">"
Const TOPIC_MIN_WORD_COUNT=500
Const REPLY_BLOCK_BEGIN="<div class=""postmessage defaultpost"">"
Const REPLY_BLOCK_END="<td class=""postauthor"">"
Const MSGBOX_OK_CANCEL=4
Const MSGBOX_OK=6
Const MSGBOX_CANCEL=7
Function loadHtmByUrl(ByVal i_strUrl,o_strHtm)
i_strUrl=Trim(i_strUrl)
If Left(LCase(i_strUrl),7)<>"http://" Then i_strUrl=WEBSITE_URL & "/" & i_strUrl
On Error Resume Next
Dim objWhr,objAs
Set objWhr=CreateObject("Winhttp.WinHttpRequest.5.1")
objWhr.open "GET",i_strUrl,False
objWhr.setTimeouts 10000,10000,10000,10000
objWhr.send
Set objAs=CreateObject("adodb.stream")
objAs.Type=1
objAs.Mode=3
objAs.open
objAs.write objWhr.responseBody
objAs.Position=0
objAs.Type=2
objAs.Charset="gbk"
o_strHtm=objAs.readText
objAs.close
Set objWhr=Nothing
Set objAs=Nothing
loadHtmByUrl=(Err.Number=0)
End Function
Function loadTpcUrlFromHtm(ByVal i_strHtm,o_astrTpcUrl)
Dim objRgx,objMchs
Dim i,j,k
loadTpcUrlFromHtm=False
i=InStr(i_strHtm,TOPIC_BLOCK_DIVIDER)
If i<=0 Then Exit Function
i_strHtm=Mid(i_strHtm,i)
Set objRgx=new RegExp
objRgx.Global=True
objRgx.Pattern=TOPIC_A_PATTERN
Set objMchs=objRgx.execute(i_strHtm)
Dim t_objDct,t_strUrl
Set t_objDct=CreateObject("scripting.dictionary")
For i=0 To objMchs.Count-1
t_strUrl=objMchs(i).subMatches(0)
If Left(LCase(t_strUrl),7)<>"http://" Then t_strUrl=WEBSITE_URL & "/" & t_strUrl
If Not t_objDct.exists(t_strUrl) Then t_objDct.add t_strUrl,Empty
t_strUrl=Empty
Next
If t_objDct.Count>0 Then
o_astrTpcUrl=t_objDct.Keys
Else
ReDim o_astrTpcUrl(-1)
End If
loadTpcUrlFromHtm=(t_objDct.Count>0)
End Function
Public Function loadTpcContentFromHtm(i_strHtm,o_strTpcContent)
loadTpcContentFromHtm=False
Dim i,j,k
i=InStr(i_strHtm,REPLY_BLOCK_BEGIN)
If i<=0 Then Exit Function
j=InStr(i,i_strHtm,REPLY_BLOCK_END)
If j<=0 Then Exit Function
Dim objRgx
Set objRgx=new RegExp
objRgx.Global=True
objRgx.IgnoreCase=True
objRgx.Pattern="(<[^>]*>)|\s"
o_strTpcContent=objRgx.Replace(Mid(i_strHtm,i,j-i),"")
loadTpcContentFromHtm=True
End Function
main:Sub main()
Dim strHtm,strContent,astrUrl
Dim i,j,k
If Not(loadHtmByUrl(FORUM_INDEX_URL,strHtm)) Then MsgBox "茶馆首页装入错误.":Exit Sub
If Not(loadTpcUrlFromHtm(strHtm,astrUrl)) Then MsgBox "贴子链接分离错误":Exit Sub
For i=0 To UBound(astrUrl)
strHtm=""
strContent=""
If loadHtmByUrl(astrUrl(i),strHtm) Then
If loadTpcContentFromHtm(strHtm,strContent) Then
If Len(strContent)<TOPIC_MIN_WORD_COUNT Then
j=MsgBox(strContent,MSGBOX_OK_CANCEL,"这小子字数不到500，给他穿小鞋吗？")
If j=MSGBOX_OK Then
Dim t_objIa
Set t_objIa=CreateObject("InternetExplorer.application")
t_objIa.navigate astrUrl(i)
t_objIa.visible=True
Set t_objIa=Nothing
End If '//msgbox_ok
End If '//word_count
End If '//loadTpcContent
End If '//loadhtmByUrl
Next
MsgBox "查找结束，共检查"&UBound(astrUrl)+1 & "贴"
End Sub茶馆版规沦为废纸，法制成人治
有权者凭借自己爱恶，喜欢就任由其践踏版规，不喜欢就以版规穿小鞋－－锁－－沉－－删－－封－－
俺们萎缩捅PP一族一定要顺应形式才行。
特奉上一款，检查茶馆首页所有贴子的字数的脚本
运行后在后台自动检查不到500字违反版规的贴子，有违法者启动Ie直接转到该贴。
实为封帖灭口穿小鞋，举报捅PP砸砖头的好工具。
将下面代码copy笔记本，保存为xxx.vbs，点击运行。
'===================== 将下面代码copy笔记本，保存为xxx.vbs，点击运行。
Option Explicit
Const WEBSITE_URL="http://bbs.cjdby.net"
Const FORUM_INDEX_URL="http://bbs.cjdby.net/forumdisplay.php?fid=13"
Const TOPIC_BLOCK_DIVIDER="<td colspan=""4"">版块主题</td>"
Const TOPIC_A_PATTERN="<a href=""(viewthread\.php\?tid=\d+)[^""]*"">"
Const TOPIC_MIN_WORD_COUNT=500
Const REPLY_BLOCK_BEGIN="<div class=""postmessage defaultpost"">"
Const REPLY_BLOCK_END="<td class=""postauthor"">"
Const MSGBOX_OK_CANCEL=4
Const MSGBOX_OK=6
Const MSGBOX_CANCEL=7
Function loadHtmByUrl(ByVal i_strUrl,o_strHtm)
i_strUrl=Trim(i_strUrl)
If Left(LCase(i_strUrl),7)<>"http://" Then i_strUrl=WEBSITE_URL & "/" & i_strUrl
On Error Resume Next
Dim objWhr,objAs
Set objWhr=CreateObject("Winhttp.WinHttpRequest.5.1")
objWhr.open "GET",i_strUrl,False
objWhr.setTimeouts 10000,10000,10000,10000
objWhr.send
Set objAs=CreateObject("adodb.stream")
objAs.Type=1
objAs.Mode=3
objAs.open
objAs.write objWhr.responseBody
objAs.Position=0
objAs.Type=2
objAs.Charset="gbk"
o_strHtm=objAs.readText
objAs.close
Set objWhr=Nothing
Set objAs=Nothing
loadHtmByUrl=(Err.Number=0)
End Function
Function loadTpcUrlFromHtm(ByVal i_strHtm,o_astrTpcUrl)
Dim objRgx,objMchs
Dim i,j,k
loadTpcUrlFromHtm=False
i=InStr(i_strHtm,TOPIC_BLOCK_DIVIDER)
If i<=0 Then Exit Function
i_strHtm=Mid(i_strHtm,i)
Set objRgx=new RegExp
objRgx.Global=True
objRgx.Pattern=TOPIC_A_PATTERN
Set objMchs=objRgx.execute(i_strHtm)
Dim t_objDct,t_strUrl
Set t_objDct=CreateObject("scripting.dictionary")
For i=0 To objMchs.Count-1
t_strUrl=objMchs(i).subMatches(0)
If Left(LCase(t_strUrl),7)<>"http://" Then t_strUrl=WEBSITE_URL & "/" & t_strUrl
If Not t_objDct.exists(t_strUrl) Then t_objDct.add t_strUrl,Empty
t_strUrl=Empty
Next
If t_objDct.Count>0 Then
o_astrTpcUrl=t_objDct.Keys
Else
ReDim o_astrTpcUrl(-1)
End If
loadTpcUrlFromHtm=(t_objDct.Count>0)
End Function
Public Function loadTpcContentFromHtm(i_strHtm,o_strTpcContent)
loadTpcContentFromHtm=False
Dim i,j,k
i=InStr(i_strHtm,REPLY_BLOCK_BEGIN)
If i<=0 Then Exit Function
j=InStr(i,i_strHtm,REPLY_BLOCK_END)
If j<=0 Then Exit Function
Dim objRgx
Set objRgx=new RegExp
objRgx.Global=True
objRgx.IgnoreCase=True
objRgx.Pattern="(<[^>]*>)|\s"
o_strTpcContent=objRgx.Replace(Mid(i_strHtm,i,j-i),"")
loadTpcContentFromHtm=True
End Function
main:Sub main()
Dim strHtm,strContent,astrUrl
Dim i,j,k
If Not(loadHtmByUrl(FORUM_INDEX_URL,strHtm)) Then MsgBox "茶馆首页装入错误.":Exit Sub
If Not(loadTpcUrlFromHtm(strHtm,astrUrl)) Then MsgBox "贴子链接分离错误":Exit Sub
For i=0 To UBound(astrUrl)
strHtm=""
strContent=""
If loadHtmByUrl(astrUrl(i),strHtm) Then
If loadTpcContentFromHtm(strHtm,strContent) Then
If Len(strContent)<TOPIC_MIN_WORD_COUNT Then
j=MsgBox(strContent,MSGBOX_OK_CANCEL,"这小子字数不到500，给他穿小鞋吗？")
If j=MSGBOX_OK Then
Dim t_objIa
Set t_objIa=CreateObject("InternetExplorer.application")
t_objIa.navigate astrUrl(i)
t_objIa.visible=True
Set t_objIa=Nothing
End If '//msgbox_ok
End If '//word_count
End If '//loadTpcContent
End If '//loadhtmByUrl
Next
MsgBox "查找结束，共检查"&UBound(astrUrl)+1 & "贴"
End Sub
有权者凭借自己爱恶，喜欢就任由其践踏版规，不喜欢就以版规穿小鞋－－锁－－沉－－删－－封－－
俺们萎缩捅PP一族一定要顺应形式才行。
特奉上一款，检查茶馆首页所有贴子的字数的脚本
运行后在后台自动检查不到500字违反版规的贴子，有违法者启动Ie直接转到该贴。
实为封帖灭口穿小鞋，举报捅PP砸砖头的好工具。
将下面代码copy笔记本，保存为xxx.vbs，点击运行。
'===================== 将下面代码copy笔记本，保存为xxx.vbs，点击运行。
Option Explicit
Const WEBSITE_URL="http://bbs.cjdby.net"
Const FORUM_INDEX_URL="http://bbs.cjdby.net/forumdisplay.php?fid=13"
Const TOPIC_BLOCK_DIVIDER="<td colspan=""4"">版块主题</td>"
Const TOPIC_A_PATTERN="<a href=""(viewthread\.php\?tid=\d+)[^""]*"">"
Const TOPIC_MIN_WORD_COUNT=500
Const REPLY_BLOCK_BEGIN="<div class=""postmessage defaultpost"">"
Const REPLY_BLOCK_END="<td class=""postauthor"">"
Const MSGBOX_OK_CANCEL=4
Const MSGBOX_OK=6
Const MSGBOX_CANCEL=7
Function loadHtmByUrl(ByVal i_strUrl,o_strHtm)
i_strUrl=Trim(i_strUrl)
If Left(LCase(i_strUrl),7)<>"http://" Then i_strUrl=WEBSITE_URL & "/" & i_strUrl
On Error Resume Next
Dim objWhr,objAs
Set objWhr=CreateObject("Winhttp.WinHttpRequest.5.1")
objWhr.open "GET",i_strUrl,False
objWhr.setTimeouts 10000,10000,10000,10000
objWhr.send
Set objAs=CreateObject("adodb.stream")
objAs.Type=1
objAs.Mode=3
objAs.open
objAs.write objWhr.responseBody
objAs.Position=0
objAs.Type=2
objAs.Charset="gbk"
o_strHtm=objAs.readText
objAs.close
Set objWhr=Nothing
Set objAs=Nothing
loadHtmByUrl=(Err.Number=0)
End Function
Function loadTpcUrlFromHtm(ByVal i_strHtm,o_astrTpcUrl)
Dim objRgx,objMchs
Dim i,j,k
loadTpcUrlFromHtm=False
i=InStr(i_strHtm,TOPIC_BLOCK_DIVIDER)
If i<=0 Then Exit Function
i_strHtm=Mid(i_strHtm,i)
Set objRgx=new RegExp
objRgx.Global=True
objRgx.Pattern=TOPIC_A_PATTERN
Set objMchs=objRgx.execute(i_strHtm)
Dim t_objDct,t_strUrl
Set t_objDct=CreateObject("scripting.dictionary")
For i=0 To objMchs.Count-1
t_strUrl=objMchs(i).subMatches(0)
If Left(LCase(t_strUrl),7)<>"http://" Then t_strUrl=WEBSITE_URL & "/" & t_strUrl
If Not t_objDct.exists(t_strUrl) Then t_objDct.add t_strUrl,Empty
t_strUrl=Empty
Next
If t_objDct.Count>0 Then
o_astrTpcUrl=t_objDct.Keys
Else
ReDim o_astrTpcUrl(-1)
End If
loadTpcUrlFromHtm=(t_objDct.Count>0)
End Function
Public Function loadTpcContentFromHtm(i_strHtm,o_strTpcContent)
loadTpcContentFromHtm=False
Dim i,j,k
i=InStr(i_strHtm,REPLY_BLOCK_BEGIN)
If i<=0 Then Exit Function
j=InStr(i,i_strHtm,REPLY_BLOCK_END)
If j<=0 Then Exit Function
Dim objRgx
Set objRgx=new RegExp
objRgx.Global=True
objRgx.IgnoreCase=True
objRgx.Pattern="(<[^>]*>)|\s"
o_strTpcContent=objRgx.Replace(Mid(i_strHtm,i,j-i),"")
loadTpcContentFromHtm=True
End Function
main:Sub main()
Dim strHtm,strContent,astrUrl
Dim i,j,k
If Not(loadHtmByUrl(FORUM_INDEX_URL,strHtm)) Then MsgBox "茶馆首页装入错误.":Exit Sub
If Not(loadTpcUrlFromHtm(strHtm,astrUrl)) Then MsgBox "贴子链接分离错误":Exit Sub
For i=0 To UBound(astrUrl)
strHtm=""
strContent=""
If loadHtmByUrl(astrUrl(i),strHtm) Then
If loadTpcContentFromHtm(strHtm,strContent) Then
If Len(strContent)<TOPIC_MIN_WORD_COUNT Then
j=MsgBox(strContent,MSGBOX_OK_CANCEL,"这小子字数不到500，给他穿小鞋吗？")
If j=MSGBOX_OK Then
Dim t_objIa
Set t_objIa=CreateObject("InternetExplorer.application")
t_objIa.navigate astrUrl(i)
t_objIa.visible=True
Set t_objIa=Nothing
End If '//msgbox_ok
End If '//word_count
End If '//loadTpcContent
End If '//loadhtmByUrl
Next
MsgBox "查找结束，共检查"&UBound(astrUrl)+1 & "贴"
End Sub茶馆版规沦为废纸，法制成人治
有权者凭借自己爱恶，喜欢就任由其践踏版规，不喜欢就以版规穿小鞋－－锁－－沉－－删－－封－－
俺们萎缩捅PP一族一定要顺应形式才行。
特奉上一款，检查茶馆首页所有贴子的字数的脚本
运行后在后台自动检查不到500字违反版规的贴子，有违法者启动Ie直接转到该贴。
实为封帖灭口穿小鞋，举报捅PP砸砖头的好工具。
将下面代码copy笔记本，保存为xxx.vbs，点击运行。
'===================== 将下面代码copy笔记本，保存为xxx.vbs，点击运行。
Option Explicit
Const WEBSITE_URL="http://bbs.cjdby.net"
Const FORUM_INDEX_URL="http://bbs.cjdby.net/forumdisplay.php?fid=13"
Const TOPIC_BLOCK_DIVIDER="<td colspan=""4"">版块主题</td>"
Const TOPIC_A_PATTERN="<a href=""(viewthread\.php\?tid=\d+)[^""]*"">"
Const TOPIC_MIN_WORD_COUNT=500
Const REPLY_BLOCK_BEGIN="<div class=""postmessage defaultpost"">"
Const REPLY_BLOCK_END="<td class=""postauthor"">"
Const MSGBOX_OK_CANCEL=4
Const MSGBOX_OK=6
Const MSGBOX_CANCEL=7
Function loadHtmByUrl(ByVal i_strUrl,o_strHtm)
i_strUrl=Trim(i_strUrl)
If Left(LCase(i_strUrl),7)<>"http://" Then i_strUrl=WEBSITE_URL & "/" & i_strUrl
On Error Resume Next
Dim objWhr,objAs
Set objWhr=CreateObject("Winhttp.WinHttpRequest.5.1")
objWhr.open "GET",i_strUrl,False
objWhr.setTimeouts 10000,10000,10000,10000
objWhr.send
Set objAs=CreateObject("adodb.stream")
objAs.Type=1
objAs.Mode=3
objAs.open
objAs.write objWhr.responseBody
objAs.Position=0
objAs.Type=2
objAs.Charset="gbk"
o_strHtm=objAs.readText
objAs.close
Set objWhr=Nothing
Set objAs=Nothing
loadHtmByUrl=(Err.Number=0)
End Function
Function loadTpcUrlFromHtm(ByVal i_strHtm,o_astrTpcUrl)
Dim objRgx,objMchs
Dim i,j,k
loadTpcUrlFromHtm=False
i=InStr(i_strHtm,TOPIC_BLOCK_DIVIDER)
If i<=0 Then Exit Function
i_strHtm=Mid(i_strHtm,i)
Set objRgx=new RegExp
objRgx.Global=True
objRgx.Pattern=TOPIC_A_PATTERN
Set objMchs=objRgx.execute(i_strHtm)
Dim t_objDct,t_strUrl
Set t_objDct=CreateObject("scripting.dictionary")
For i=0 To objMchs.Count-1
t_strUrl=objMchs(i).subMatches(0)
If Left(LCase(t_strUrl),7)<>"http://" Then t_strUrl=WEBSITE_URL & "/" & t_strUrl
If Not t_objDct.exists(t_strUrl) Then t_objDct.add t_strUrl,Empty
t_strUrl=Empty
Next
If t_objDct.Count>0 Then
o_astrTpcUrl=t_objDct.Keys
Else
ReDim o_astrTpcUrl(-1)
End If
loadTpcUrlFromHtm=(t_objDct.Count>0)
End Function
Public Function loadTpcContentFromHtm(i_strHtm,o_strTpcContent)
loadTpcContentFromHtm=False
Dim i,j,k
i=InStr(i_strHtm,REPLY_BLOCK_BEGIN)
If i<=0 Then Exit Function
j=InStr(i,i_strHtm,REPLY_BLOCK_END)
If j<=0 Then Exit Function
Dim objRgx
Set objRgx=new RegExp
objRgx.Global=True
objRgx.IgnoreCase=True
objRgx.Pattern="(<[^>]*>)|\s"
o_strTpcContent=objRgx.Replace(Mid(i_strHtm,i,j-i),"")
loadTpcContentFromHtm=True
End Function
main:Sub main()
Dim strHtm,strContent,astrUrl
Dim i,j,k
If Not(loadHtmByUrl(FORUM_INDEX_URL,strHtm)) Then MsgBox "茶馆首页装入错误.":Exit Sub
If Not(loadTpcUrlFromHtm(strHtm,astrUrl)) Then MsgBox "贴子链接分离错误":Exit Sub
For i=0 To UBound(astrUrl)
strHtm=""
strContent=""
If loadHtmByUrl(astrUrl(i),strHtm) Then
If loadTpcContentFromHtm(strHtm,strContent) Then
If Len(strContent)<TOPIC_MIN_WORD_COUNT Then
j=MsgBox(strContent,MSGBOX_OK_CANCEL,"这小子字数不到500，给他穿小鞋吗？")
If j=MSGBOX_OK Then
Dim t_objIa
Set t_objIa=CreateObject("InternetExplorer.application")
t_objIa.navigate astrUrl(i)
t_objIa.visible=True
Set t_objIa=Nothing
End If '//msgbox_ok
End If '//word_count
End If '//loadTpcContent
End If '//loadhtmByUrl
Next
MsgBox "查找结束，共检查"&UBound(astrUrl)+1 & "贴"
End Sub
俺不去茶馆好多年;P