CSDN分页ID提取工具（vb编写）

概述分页党统计专用工具   下载地址：http://download.csdn.net/source/2984669   Option ExplicitDim strData$, i%Dim reg As ObjectDim matchs As ObjectDim dic As Object, tmpDim XmlHttp As ObjectDim strUrlPre As S

分页党统计专用工具

下载地址：http://download.csdn.net/source/2984669

Option ExplicitDim strData$,i%Dim reg As ObjectDim matchs As ObjectDim dic As Object,tmpDim Xmlhttp As ObjectDim strUrlPre As String 'url前缀 Private Sub Form_Load() Set Xmlhttp = CreateObject("Microsoft.XMLhttp") Set dic = CreateObject("scripting.dictionary") Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.IgnoreCase = TrueEnd SubPrivate Sub Command1_Click() Dim intPageStart As Integer Dim intPageEnd As Integer dic.removeall reg.Pattern = "(.+?)(?:/.HTML|_/d+)" Set matchs = reg.Execute(Text1.Text) strUrlPre = matchs(0).SubMatches(0) reg.Pattern = ">共(/d+)页</a>" strData = getHTMLStr(strUrlPre & ".HTML") Set matchs = reg.Execute(strData) intPageEnd = matchs(0).SubMatches(0) DeBUG.Print strUrlPre & ".HTML" Text2.Text = strUrlPre & ".HTML" & vbCrLf intPageStart = Val(txtStartPage.Text) reg.Pattern = "<li center""><a href=""http://hi.csdn.net/(.+?)""" For i = intPageStart To intPageEnd '页码2~最大页 If i < 2 Then i = 1 strData = getHTMLStr(strUrlPre & ".HTML") Else strData = getHTMLStr(strUrlPre & "_" & i & ".HTML") End If Set matchs = reg.Execute(strData) If matchs.Count > 0 Then dic(matchs(0).SubMatches(0)) = dic(matchs(0).SubMatches(0)) + 1 DeBUG.Print Format(i,"0000 ") & matchs(0).SubMatches(0) Text2.SelStart = Len(Text2.Text) Text2.SelText = Format(i,"0000 ") & matchs(0).SubMatches(0) & vbCrLf Else dic("MLGB404") = dic("MLGB404") + 1 End If Next DeBUG.Print "========结果汇总========" Text2.SelStart = Len(Text2.Text) Text2.SelText = "========结果汇总========" & vbCrLf For Each tmp In dic.keys DeBUG.Print tmp & vbTab & dic(tmp) Text2.SelStart = Len(Text2.Text) Text2.SelText = tmp & vbTab & dic(tmp) & vbCrLf NextEnd Sub'得到utf8格式的网页的代码Public Function getHTMLStr(strUrl As String) As String Dim Xmlhttp As Object Set Xmlhttp = CreateObject("Microsoft.XMLhttp") Xmlhttp.Open "GET",strUrl,False On Error GoTo Err_net Xmlhttp.send getHTMLStr = BytesToBstr(Xmlhttp.ResponseBody,"UTF-8") Set Xmlhttp = nothingErr_net:End Function'转utf8格式Private Function BytesToBstr(strBody,codeBase) As String Dim obJstream As Object Set obJstream = CreateObject("Adodb.Stream") obJstream.Type = 1 obJstream.Mode = 3 obJstream.Open obJstream.Write strBody obJstream.position = 0 obJstream.Type = 2 obJstream.Charset = codeBase BytesToBstr = obJstream.ReadText obJstream.Close Set obJstream = nothingEnd Function

注意不要大量采集，否则可能会被csdn服务器拒绝，报403 ForbIDden错误，这时你所有的帖子都访问不了了，要过一段时间才好。建议采集处加个延时。

总结

以上是内存溢出为你收集整理的CSDN分页ID提取工具（vb编写）全部内容，希望文章能够帮你解决CSDN分页ID提取工具（vb编写）所遇到的程序开发问题。

如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。