------------------get 6642 Content--------------------------------------------
Form1.frm
'UptadeRunlight(Html Marquee Element) in vb6
'By wgscd 2008/11/7
'HTTP://www.blog.csdn.net/wgsnet
'QQ:153964481
VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "shdocvw.dll"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "Form1"
ClientHeight = 3330
ClientLeft = 45
ClientTop = 330
ClientWidth = 8805
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3330
ScaleWidth = 8805
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox TextInitID
Height = 375
Left = 3840
TabIndex = 6
Text = "10000"
Top = 240
Width = 735
End
Begin VB.TextBox TextMaxid
Height = 375
Left = 5880
TabIndex = 5
Text = "16808"
Top = 240
Width = 1215
End
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 255
Left = 240
TabIndex = 3
Top = 3000
Width = 8415
_ExtentX = 14843
_ExtentY = 450
_Version = 393216
Appearance = 1
End
Begin VB.TextBox Text1
Height = 1455
Left = 240
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 2
Top = 1080
Width = 7695
End
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 495
Left = 7200
TabIndex = 1
Top = 240
Width = 1215
End
Begin SHDocVwCtl.WebBrowser WebBrowser1
Height = 255
Left = 240
TabIndex = 0
Top = 1680
Width = 7695
ExtentX = 13573
ExtentY = 450
ViewMode = 0
Offline = 0
Silent = 0
RegisterAsBrowser= 0
RegisterAsDropTarget= 1
AutoArrange = 0 'False
NoClientEdge = 0 'False
AlignLeft = 0 'False
NoWebView = 0 'False
HideFileNames = 0 'False
SingleClick = 0 'False
SingleSelection = 0 'False
NoFolders = 0 'False
Transparent = 0 'False
ViewID = "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
Location = "http://www.soso.com/"
End
Begin VB.Label Label3
Caption = "结束ID:"
Height = 375
Left = 5040
TabIndex = 8
Top = 240
Width = 855
End
Begin VB.Label Label2
Caption = "开始ID"
Height = 375
Left = 2760
TabIndex = 7
Top = 240
Width = 975
End
Begin VB.Label Label1
Height = 375
Left = 240
TabIndex = 4
Top = 2520
Width = 2415
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim strResult As String
Dim maxid As Integer
Sub Form_Load()
maxid = GetHttpPage("http://www.haosemm.com/Thief/AccessTopicMaxid.asp")
TextMaxid.Text = maxid
End Sub
'http://www.haosemm.com/Thief/AccessTopic.asp?id=16709
'Thief/AccessTopicMaxID.asp
Private Sub Command1_Click()
'GetHttpPage ("http://blog.qq.com/2008/pic08/aymv/")
Dim maxNum As Integer
maxNum = TextMaxid.Text
Dim i As Single
ProgressBar1.Max = maxNum
For i = TextInitID.Text To maxNum
Dim str As String
Dim tempstr
str = GetHttpPage("http://www.haosemm.com/Thief/AccessTopic.asp?id=" & Format(i, "00000"))
If str <> "Null" Then
tempstr = Split(str, "<|>")
strResult = strResult & "[-title-]" & tempstr(3) & "[-content-]" & tempstr(4) & "[-itemspliter-]" & vbNewLine
Dim rstr As String
rstr = "<script language='JavaScript' src='http://www.sms888.net/web/script/photojet.js?uid=5494&t=1' type='text/javascript' id='SMS888_Pic' charset='gb2312'></script>"
strResult = Replace(strResult, rstr, "<a target=""_blank"" href=""http://blog.sina.com.cn/s/blog_56fda1650100ao5p.html"">雪白少妇无法控制自己的强烈欲望</a>")
Else
strResult = strResult & str
End If
ProgressBar1.Value = i
ProgressBar1.Refresh
Me.Label1.Caption = i
Me.Label1.Refresh
Next
'Me.Text1.Text = str
SaveToFile "C:/1.txt", strResult
'
End Sub
Function GetHttpPage(HttpUrl)
If IsNull(HttpUrl) = True Or HttpUrl = "$False$" Then
GetHttpPage = "$False$"
Exit Function
End If
Dim http
Set http = CreateObject("MicroSoft.XMLHTTP")
http.Open "GET", HttpUrl, False
http.Send
If http.ReadyState <> 4 Then
Set http = Nothing
GetHttpPage = "$False$"
Exit Function
End If
If http.Status = 404 Then '找不到页面
'MsgBox "404"
GetHttpPage = "$False$"
Exit Function
End If
GetHttpPage = BytesToBstr(http.responseBody, "GB2312")
Set http = Nothing
If Err.Number <> 0 Then
Err.Clear
End If
End Function
Function BytesToBstr(Body, Cset)
Dim Objstream
Set Objstream = CreateObject("adodb.stream")
Objstream.Type = 1
Objstream.Mode = 3
Objstream.Open
Objstream.Write Body
Objstream.position = 0
Objstream.Type = 2
Objstream.Charset = Cset
BytesToBstr = Objstream.ReadText
Objstream.Close
Set Objstream = Nothing
End Function
Function GetBody(ConStr, StartStr, OverStr, IncluL, IncluR)
If ConStr = "$False$" Or ConStr = "" Or IsNull(ConStr) = True Or StartStr = "" Or IsNull(StartStr) = True Or OverStr = "" Or IsNull(OverStr) = True Then
GetBody = "$False$"
Exit Function
End If
Dim ConStrTemp
Dim Start, Over
ConStrTemp = LCase(ConStr)
StartStr = LCase(StartStr)
OverStr = LCase(OverStr)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
If Start <= 0 Then
GetBody = "$False$"
Exit Function
Else
If IncluL = False Then
Start = Start + LenB(StartStr)
End If
End If
Over = InStrB(Start, ConStrTemp, OverStr, vbBinaryCompare)
If Over <= 0 Or Over <= Start Then
GetBody = "$False$"
Exit Function
Else
If IncluR = True Then
Over = Over + LenB(OverStr)
End If
End If
GetBody = MidB(ConStr, Start, Over - Start)
End Function
Function ShowErr(ErrMsg)
response.Write "<script>alert('" & ErrMsg & "');history.back();</script>"
response.End
End Function
'-------------------------------------------------
'过程名: RegUrl(TheStr)
'说明 : 提取需要的HTML内容 'By wgcd
'返回类型: string
'----------------------------------------------------
Function RegUrl(TheStr)
Dim matchStr, strTemp
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True '****这一句加上是全部替换,如果不加,只替换第一个
regEx.Pattern = "(<li><img style=""cursor:pointer.*/></li>)"
' 把所有匹配的HTML代码放入Matches集合
'dim str1
'str1="<li><img style=""cursor:pointer; width:120px; height:90px"" alt="""
Set Matches = regEx.Execute(TheStr)
' 显示所有匹配的HTML代码
For Each Item In Matches
List1.AddItem (Item.Value)
matchStr = matchStr & Item.Value
matchCount = matchCount + 1
Next
' 显示其中一项
' List1.AddItem (Matches.Item(0).Value)
matchStr = Replace(matchStr, "<li><img style=""cursor:pointer; width:120px; height:90px"" alt=""", vbNewLine)
matchStr = Replace(matchStr, """ title=""", "|")
matchStr = Replace(matchStr, """ οnclick=""window.open('/b/", "|http://www.showle.com/flvplayer.swf?auto=1&vid=")
matchStr = regReplace(matchStr, "-.*html.*src=/""", "|") '正则表达式替换
matchStr = Replace(matchStr, """ /></li>", "")
List1.AddItem (matchStr) '输出
RegUrl = matchStr
End Function
'--------------------------------------------------------
'-------------------------------------------------
'过程名: regReplace
'说明 : '正则表达式替换 By wgcd
'返回类型: string
'----------------------------------------------------
Function regReplace(str, patrn, rstr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.Global = True
regReplace = regEx.Replace(str, rstr)
End Function
'----------------------------------------------------
'-------------------------------------------------
'过程名: SaveToFile(ByVal strFileName,strContent)
'说明 : '保存文件 By wgcd
'参数 : strFileName 保存名字
'参数 : strContent 内容
'返回类型: string
'----------------------------------------------------
Function SaveToFile(ByVal strFileName, strContent)
Set fso = CreateObject("Scripting.FileSystemObject")
Set hf = fso.CreateTextFile(strFileName, True)
'hf.write vbcrlf
hf.Write strContent
hf.Close
Set hf = Nothing
Set fso = Nothing
End Function
Private Sub Command2_Click()
Me.Text1.Text = RegUrl(Me.Text1.Text)
End Sub
Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)
If Text = "完毕" Then
Me.Caption = "OK"
End If
End Sub