本帖vb源代码-回复灌水检测机【吾爱破解专用】

Private Declare Function ShellExecute Lib"shell32.dll"Alias "ShellExecuteA" (ByVal hwnd AsLong,ByVal lpOperation As String,ByVal lpFile As String,ByVal lpParameters As String,ByVallpDirectory As String,ByVal nShowCmd As Long)As Long'声明

Sub ClearDups(lst As Control, comptype As Boolean)

Dim i&, j&, tmp$(),c ID&, ls tCount&, s Comptype&, tmpLine$ls t.Vis ib le=F als els t C o unt=ls t.Lis t C o unt - 1

If lstCount<0 Then Exit Sub

ReDim tmp(ls tCount)

If c omptype Then s Comptype=0 Els e s Comptype=1

For j=lstCount To 0 Step-1tmp Lin e=ls t.Lis t(j)

For i=0 TocID- 1

If StrComp(tmp(i), tmpLine, s Comptype)=0 Thenlst.RemoveItem j

Exit For

End If

Next

If i>cID- 1 Thentmp(cI D)=tmp LinecID=cID+1

End If

Nextls t.Vis ib le=T rue

End Sub

Function ChkList()As Boo lean

Dim m As Integer

F or m=0 To Lis t 1.Lis tCount - 1

If List 1.List(m)=zihao Then

ChkL is t=F als e

Els e

ChkL is t=T rue

End If

Next

End Function

Public Function FindStrMulti$(Strall$,FirstStr$,EndStr$,SplitStr$)

Dim i&, j&j=1

Doi=InStr(j,Strall,FirstStr)

If i=0 Then

Exit Do

End Ifi=i+Len(F ir s tS tr)j=In S tr(i,S trall,EndS tr)

If j>0 Then

F indStrMulti=IIf(Len(F indStrMulti)>0,FindStrMulti&SplitStr, "")&Mid(Strall, i, j -i)

Els e

Exit Do

End If

Loop

End Function

Private Sub Command1_Click()

Web Brow s er 1.Navigate Text 1.Text

Call Command2_Click

Lab e l 1.Vis ib le=True

End Sub

Private Sub Command2_Click()

On Error Resume Next

For i=0 To WebBrow s er 1.Document.links.Length- 1

Dim zihao As String

If InStr(WebBrowser1.Document.links.Item(i),"http://www.52pojie.c n/forum.php?mod=redirec t&goto=findpost&ptid=")Thenzihao = WebBrow s er 1.Doc ument.links.Item(i).innerText & "--" &Web Brow s er 1.Document.getelementbyid("postmes s age_" &FindStrMult i(Web Brow s er 1.Document.links.Item(i)&"abc", "&pid=", "abc", "")).innerTextIf List 1.ListCount=0 Then List 1.AddItem zihao

If ChkList=True Then List 1.AddItem zihao

End If

Next i

End Sub

Private Sub Command3_Click()

Dim sT!sT=Timer

ClearDups List 1,True

Lab el 1.Capt ion="本帖回复"&Lis t 1.Lis tCount&"次/"&I nt(Lis t 1.Lis tCount / 10)+1&"页"

End Sub

Private Sub Command4_Click()

On Error Resume Next

Dim outdatatxt As String

Open"d:\回复记录.txt"F or Output As#1

F or i=0 To Lis t 1.Lis tCount - 1

Pr int#1,Lis t 1.Lis t(i)

Next i

Close#1

Ms gBox"已保存在“d:\回复记录.txt”中", , "提示"

End Sub

Private Sub Command5_Click()

On Error Resume Next

F or i=0 To Lis t 1.Lis tCount - 1

Dim m As Stringm=F indS trMulti(L is t 1.Lis t(i)&"ENT ER", "--", "ENTE R", "")

Dim Sum&

S um=0

For c=1 To Len(m)

Char=Mid(m,c, 1)

If (AscW(Char) > -40870 And AscW(Char) < -19967) Or (AscW(Char) < 40870 AndAs c W(Char)>19967)Then

S um=S um+1

End If

Next c

If Sum<=1 Then

Lis t2.AddItem Lis t 1.Lis t(i)

End If

Next i

If List2.ListCount=0 Then

MsgBox"貌似本帖无人灌水、 ", , "好现象"

End If

End Sub

Private Sub Form_Load()

Web Brow s er 1.Navigate"http://www.52pojie.cn/"

End Sub

Private Sub Label3_Click()

On Error Resume Next

ShellEx ecute 0, "open", "http://b log.sina.c om.cn/s/blog_92b6d74d01012s 3r.html", vbNullString,vbNul lS tring, 3

End Sub

Private Sub Text1_Change()

If List 1.ListCount<>0 Then

For a=List1.ListCount - 1 To 0 Step-1

Lis t 1.RemoveItem(a)

Next a

End If

I f Lis t2.Lis tCount<>0 Then

For a=List2.ListCount - 1 To 0 Step-1

Lis t2.RemoveI tem(a)

Next a

End If

Label1.Caption=""

Web Brow s er 1.Navigate"about:b lank"

End Sub

Private Sub Text1_GotFocus()

Text 1.SelStart=0

Text 1.S elLength=Len(Text 1)

End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object,URL As Variant)For i=0 To WebBrow s er 1.Document.links.Length- 1

If WebBrows er 1.Document.links.Item(i).innerText="下一页"Then

WebBrowser 1.Navigate WebBrowser 1.Document.links.Item(i)

End If

Next i

Call Command2_Click

End Sub