小白也抓网——分享网抓作品

renahu · 发表于 2014-11-4 17:58

本帖最后由 renahu 于 2014-11-9 14:20 编辑

引子玄发表于 2014-11-1 20:15
学好了就好，我给个题目，测试你学得如何？请接题——

这个网页里的“大小盘走势”指数，用fiddler方法如 ...

Sub 大小球盘口() '练习五
Dim strText$, arr, brr, crr(), drr(), err(), lab As Boolean, trr, ds
Set ds = CreateObject("scripting.dictionary")
Cells.Clear
[a:f].HorizontalAlignment = xlCenter
[a1:f1].Font.ColorIndex = 2
[a1:f1].Interior.Color = RGB(25, 156, 223)
Range("b1:b65536").NumberFormatLocal = "0.000"
Range("d1:d65536").NumberFormatLocal = "0.000"
Range("e1:e65536").NumberFormatLocal = "mm-dd hh:mm:ss"
Top = Array("序", "大球", "大小球盘口", "小球", "变化时间", "状态")
[a1].Resize(1, 6) = Top
ActiveWindow.DisplayGridlines = True
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://fenxi.310v.net/odds_pic/panlu.html?match_id=939357&company_id=397", False
.send
strText = Split(Split(.responseText, "var BPK = [];")(1), "function sort_pk(d1,d2)")(0)
strText = Left(strText, Len(strText) - 3)
arr = Split(strText, ";")
For i = 0 To UBound(arr)
arr(i) = Replace(Replace(arr(i), "BPK[" & i + Split(Split(arr(i), "BPK[")(1), "]")(0) - i & "]=[", ""), "]", "")
arr(i) = Right(arr(i), Len(arr(i)) - 1)
ReDim Preserve drr(i)
drr(i) = Split(arr(i), ",")(1)
ReDim Preserve err(i)
err(i) = Mid(Split(arr(i), ",")(0), 2, Len(Split(arr(i), ",")(0)) - 2)
Next
For i = 0 To UBound(err)
ds(err(i)) = drr(i)
Next
.Open "GET", "http://fenxi.310v.net/data/panlu/panlu/939/b939357_397.js?d=1414914106552 ", False
.send
strText = Split(.responseText, "d3=[];")(1)
strText = Left(strText, Len(strText) - 2)
brr = Split(strText, ";")
brr(0) = Replace(brr(0), "d3[0]=", "d3.push(") & ")"
For i = 0 To UBound(brr)
brr(i) = Replace(Replace(brr(i), "d3.push(""", ""), """)", "")
brr(i) = Right(brr(i), Len(brr(i)) - 1)
ReDim Preserve crr(0 To UBound(brr), 0 To 5)
crr(i, 0) = i + 1
For x = 0 To 4
crr(i, x + 1) = Split(brr(i), ",")(x)
Next
crr(i, 2) = err(crr(i, 2) - 1) & "球"
If i > 0 Then
If ds(Split(crr(i, 2), "球")(0)) > ds(Split(crr(i - 1, 2), "球")(0)) Then
crr(i, 2) = crr(i, 2) & " 升"
ElseIf ds(Split(crr(i, 2), "球")(0)) < ds(Split(crr(i - 1, 2), "球")(0)) Then
crr(i, 2) = crr(i, 2) & " 降"
End If
If crr(i, 5) = 1 Then
crr(i, 5) = ""
ElseIf crr(i, 5) = 3 And crr(i - 1, 5) = "" And lab = False Then
crr(i, 5) = "即"
ElseIf crr(i, 5) = 3 And crr(i - 1, 5) = "即" Then
crr(i, 5) = "临"
ElseIf crr(i, 5) = 3 And crr(i - 1, 5) = "临" Then
crr(i, 5) = "": lab = True
ElseIf crr(i, 5) = 3 And lab = True Then
crr(i, 5) = ""
End If
Else
crr(i, 5) = "早"
End If
Next
'颠倒顺序
trr = crr
For i = UBound(crr) To 0 Step -1
m = m + 1
For j = 0 To UBound(crr, 2)
trr(m - 1, j) = crr(i, j)
Next
Next
End With
Sheet1.[a2].Resize(UBound(trr) + 1, 6) = trr
'设置颜色
For j = 0 To UBound(trr, 2)
Select Case j
Case 1
For i = UBound(trr) - 1 To 0 Step -1
If trr(i, j) > trr(i + 1, j) Then
Cells(i + 2, j + 1).Font.ColorIndex = 1
Cells(i + 2, j + 1).Interior.Color = RGB(255, 223, 223)
ElseIf trr(i, j) < trr(i + 1, j) Then
Cells(i + 2, j + 1).Font.ColorIndex = 1
Cells(i + 2, j + 1).Interior.Color = RGB(196, 255, 196)
End If
Next
Case 2
For i = UBound(trr) - 1 To 0 Step -1
If Right(trr(i, j), 1) = "升" Then
Cells(i + 2, j + 1).Font.ColorIndex = 1
Cells(i + 2, j + 1).Interior.Color = RGB(255, 223, 223)
Cells(i + 2, j + 1).Characters(Start:=Len(Cells(i + 2, j + 1)), Length:=1).Font.ColorIndex = 3
ElseIf Right(trr(i, j), 1) = "降" Then
Cells(i + 2, j + 1).Font.ColorIndex = 1
Cells(i + 2, j + 1).Interior.Color = RGB(196, 255, 196)
Cells(i + 2, j + 1).Characters(Start:=Len(Cells(i + 2, j + 1)), Length:=1).Font.ColorIndex = 32
End If
Next
Case 3
For i = UBound(trr) - 1 To 0 Step -1
If trr(i, j) > trr(i + 1, j) Then
Cells(i + 2, j + 1).Font.ColorIndex = 1
Cells(i + 2, j + 1).Interior.Color = RGB(255, 223, 223)
ElseIf trr(i, j) < trr(i + 1, j) Then
Cells(i + 2, j + 1).Font.ColorIndex = 1
Cells(i + 2, j + 1).Interior.Color = RGB(196, 255, 196)
End If
Next
Case 5
For i = UBound(trr) To 0 Step -1
If trr(i, j) = "早" Then
Cells(i + 2, j + 1).Font.ColorIndex = 2
Cells(i + 2, j + 1).Interior.ColorIndex = 32
ElseIf trr(i, j) = "即" Then
Cells(i + 2, j + 1).Font.ColorIndex = 2
Cells(i + 2, j + 1).Interior.ColorIndex = 3
ElseIf trr(i, j) = "临" Then
Cells(i + 2, j + 1).Font.ColorIndex = 2
Cells(i + 2, j + 1).Interior.ColorIndex = 10
End If
Next
End Select
Next
'画表格线
Cells.Borders.LineStyle = xlNone
With Range("a1:f" & Range("a65536").End(xlUp).Row).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub

复制代码

我在 blanksoul12 的基础上进行了精细化，并完全按照网上的格式和内容显示，几乎完全一样了。这抓的够全吧

renahu · 发表于 2014-11-4 18:04

blanksoul12 发表于 2014-11-2 17:35
又是笨笨的代碼,請問那些數據是否可以用JAVA分開呢?

我在你的基础上进行了精加工，把所有多余隐藏字符都干掉了，这活儿够细吧

网抓大小球.rar (163.16 KB, 下载次数: 240)

renahu · 发表于 2014-11-4 18:05

onlycxb 发表于 2014-11-2 07:54
全是百度网页，最好多换几个网页抓抓。

看看我的新作，精细版的网抓大小球

renahu · 发表于 2014-11-4 18:39

renahu 发表于 2014-11-4 17:58
我在 blanksoul12 的基础上进行了精细化，并完全按照网上的格式和内容显示，几乎完全一样了。这抓的够全吧 ...

这可是集各种技术啊，数据抓取，数据处理，颜色及表格处理，身为小白的我忙乎了几天，攻克了道道难关啊，终于问世了。

引子玄 · 发表于 2014-11-4 18:48

本帖最后由引子玄于 2014-11-15 14:34 编辑

......................

renahu · 发表于 2014-11-4 18:50

引子玄发表于 2014-11-4 18:48
你把“让球盘走势数据”和“胜平负走势数据”抓下来（这两块采集代码 blanksoul12 没写），也好证明自己是 ...

你这是激将法啊，呵呵，不过我觉得抓这些数据有什么用啊？你du球啊？

renahu · 发表于 2014-11-4 19:01

renahu 发表于 2014-11-4 18:50
你这是激将法啊，呵呵，不过我觉得抓这些数据有什么用啊？你du球啊？

你这个大小球网址的内容怎么总不变呀，怎么没有跟时间关联上，如果抓航班信息，一次弄好后，一点击都能自动更新，你这个网的内容怎么是死的？

renahu · 发表于 2014-11-5 19:40

本帖最后由 renahu 于 2014-11-9 14:21 编辑

再上一个图文并茂的，欧洲股指实时查询：

Sub 欧洲股市指数查询() '练习六
Dim url$, STxt1$, STxt2$, arr, brr(), crr(), myObj As Shape
Cells.Clear
For Each myObj In ActiveSheet.Shapes
If Not myObj.Name Like "Button*" Then myObj.Delete
Next
[a:j].HorizontalAlignment = xlCenter
[a21:a65536].HorizontalAlignment = xlLeft
[a20:j20].Font.ColorIndex = 2
[a20:j20].Interior.Color = RGB(25, 156, 223)
Range("b21:b65536").NumberFormatLocal = "0.00"
Range("c21:c65536").NumberFormatLocal = "0.00"
Range("e21:h65536").NumberFormatLocal = "0.00"
Range("j21:j65536").NumberFormatLocal = "mm-dd hh:mm"
Top = [{"指数名称","最新价","涨跌额","涨跌幅","最高","最低","开盘","昨收","振幅","最新行情时间"}]
[a20].Resize(1, 10) = Top
With CreateObject("msxml2.xmlhttp")
'抓数据
url = "http://hq2gjgp.eastmoney.com/EM_Quote2010NumericApplication/Index.aspx?reference=rtj&Type=Z&jsName=quote_global&ids=NKY7,KOSPI7,FSSTI7,TWSE7,SENSEX7,JCI7,VNINDEX7,FBMKLC7,SET7,KSE1007,PCOMP7,CSEALL7,AS517,NZSE50FG7,CASE7,INDU7,SPX7,CCMP7,SPTSX7,MEXBOL7,IBOV7,UKX7,DAX7,CAC7,IBEX7,FTSEMIB7,AEX7,SMI7,OMX7,ICEXI7,ISEQ7,INDEXCF7,ASE7,BEL207,LUXXX7,KFX7,HEX7,OBX7,ATX7,WIG7,PX7"
.Open "get", url, False
.send
'整理数据
strText = Split(Split(.responseText, """UKX7,UKX,")(1), "]}")(0)
arr = Split(strText, """,""")
arr(0) = "UKX7,UKX," & arr(0)
ReDim Preserve brr(0 To UBound(arr), 0 To 32)
ReDim Preserve crr(0 To UBound(arr), 0 To 9)
For i = 0 To UBound(arr)
For x = 0 To 32
brr(i, x) = Split(arr(i), ",")(x)
Next
Next
For i = 0 To UBound(brr)
For x = 0 To UBound(brr, 2)
Select Case x
Case 2
crr(i, 0) = brr(i, x)
Case 5
crr(i, 1) = brr(i, x)
Case 10
crr(i, 2) = brr(i, x)
Case 11
crr(i, 3) = brr(i, x)
Case 6
crr(i, 4) = brr(i, x)
Case 7
crr(i, 5) = brr(i, x)
Case 4
crr(i, 6) = brr(i, x)
Case 3
crr(i, 7) = brr(i, x)
Case 13
crr(i, 8) = brr(i, x)
Case 28
crr(i, 9) = brr(i, x)
End Select
Next
Next
'抓走势图地址
url = "http://quote.eastmoney.com/center/europe.html"
.Open "get", url, False
.send
strText = ByteToStr(.Responsebody, "GB2312")
drr = Split(strText, "height=""135"" src=""")
For i = 1 To UBound(drr)
drr(i) = Split(drr(i), """ data-trade=""")(0)
Next
Cells(1, 1).Select: ActiveSheet.Pictures.Insert drr(1)
Cells(12, 1).Select: ActiveSheet.Pictures.Insert drr(2)
Cells(1, 5).Select: ActiveSheet.Pictures.Insert drr(3)
Cells(12, 5).Select: ActiveSheet.Pictures.Insert drr(4)
Cells(1, 9).Select: ActiveSheet.Pictures.Insert drr(5)
Cells(12, 9).Select: ActiveSheet.Pictures.Insert drr(6)
'往表里写数据
[a21].Resize(UBound(crr) + 1, 10) = crr
'设置颜色
Range("a21:a" & Range("a65536").End(xlUp).Row).Font.ColorIndex = 32
For i = 0 To UBound(crr)
For j = 1 To UBound(crr, 2) - 3
Select Case j
Case 1, 4, 5, 6
If crr(i, j) > crr(i, 7) Then
Cells(i + 21, j + 1).Font.ColorIndex = 3
ElseIf crr(i, j) < crr(i, 7) Then
Cells(i + 21, j + 1).Font.ColorIndex = 10
End If
Case 3
If Left(crr(i, j), Len(crr(i, j)) - 1) > 0 Then
Cells(i + 21, j + 1).Font.ColorIndex = 3
ElseIf Left(crr(i, j), Len(crr(i, j)) - 1) < 0 Then
Cells(i + 21, j + 1).Font.ColorIndex = 10
End If
Case Else
If crr(i, j) > 0 Then
Cells(i + 21, j + 1).Font.ColorIndex = 3
ElseIf crr(i, j) < 0 Then
Cells(i + 21, j + 1).Font.ColorIndex = 10
End If
End Select
Next
Next
'画表格线
Cells.Borders.LineStyle = xlNone
With Range("a20:j" & Range("a65536").End(xlUp).Row).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Sub
Function ByteToStr(arrByte, strCharset As String) As String
With CreateObject("Adodb.Stream")
.Type = 1 'adTypeBinary
.Open
.Write arrByte
.Position = 0
.Type = 2 'adTypeText
.Charset = strCharset
ByteToStr = .Readtext
.Close
End With
End Function

复制代码

renahu · 发表于 2014-11-5 19:48

onlycxb 发表于 2014-11-4 16:50
你这个徒手擒拿，如能讲解一下最好，也算是造福网民。

老师，看看这个如何，图文并茂，还是实时的

网抓欧股指数.rar (56.86 KB, 下载次数: 183)

renahu · 发表于 2014-11-5 20:02

引子玄发表于 2014-11-4 18:48
你把“让球盘走势数据”和“胜平负走势数据”抓下来（这两块采集代码 blanksoul12 没写），也好证明自己是 ...

这个欧股股指实时查询还是比较实用

		自动登录	找回密码
密码			免费注册

[分享] 小白也抓网——分享网抓作品

点评

评分

点评

点评

点评