网页抓取分享

VBA万岁

onlycxb 发表于 2014-10-15 10:38
谢谢你的鲜花,数据结构图可以在代码调试过程中,通过本地窗口观察得到(数据量大,用这种方式比较直观)

多谢帮助——之前没用过本地窗口，不知为何物，今得以指点，方明白一二！

onlycxb

继续分享
分享5:

1. Sub 十一运网抓()
   
2.     Dim Xml As New MSXML2.XMLHTTP, strTxt As String, Url As String
   
3.     Dim arr, brr, Crr, i%, n%, t, s, Drr, Sh As Worksheet
   
4.     Dim j%
   
5.     Set Sh = Sheets("网抓数据")
   
6.     '－－－－－－－－－－－－－－－－这里是抓取网页数据开始－－－－－－－－－－－－－－－－
   
7.     t = Timer
   
8.     Url = "http://taobao.cjcp.com.cn/cjw11x5/view/11x5qianerzs.php?searchType=2&xingType=2&lotteryType=11ydj"
   
9.     With Xml
   
10.         .Open "POST", Url, False
    
11.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
12.         .Send "HighSelectYear=&HighSelectMonth=&HighSelectYangLi=&HighSelectYinLi=&HighSelectWeek=&HighSelectQishuEnd=&HighSelectQishujo=&HighSelectJQ=&HighSelectzu3=&HighSelectzu6=&HighSelectjiqiu=&Qishu=1000&button2=开始筛选"
    
13.         strTxt = BytesToBstr(.responseBody, "GB2312")
    
14.     End With
    
15. 
    
16.     s = Split(Split(strTxt, "<!--当前历史数据-->")(1), "<!--历史统计数据-->")(0)
    
17.     strTxt = Split(Split(strTxt, "<tbody id=""info"">")(1), "</tbody>")(0)
    
18. 
    
19.     arr = Split(strTxt, "<tr")
    
20.     ReDim Crr(1 To 1000, 1 To 3)
    
21.     For i = UBound(arr) To 1 Step -1
    
22.         brr = Split(arr(i), "</td>")
    
23.         n = n + 1
    
24.         Crr(n, 1) = Split(brr(0), ">")(2): Crr(n, 2) = Split(brr(1), ">")(1): Crr(n, 3) = Split(brr(2), ">")(1)
    
25.     Next i
    
26. 
    
27.     '－－－－这里是改写数据开始－－－－－－－－如果新抓取的数据期号与B2单元格值不相同，则改写数据
    
28. '    If Crr(1, 2) <> Trim(Sh.[b3]) Then
    
29.         Sh.[i4:Af8].ClearContents
    
30.         With Sh.[a3].Resize(1000, 3)
    
31.             .ClearContents
    
32.             .Value = Crr
    
33.         End With
    
34.         '预测行二数据正理
    
35.         s = Replace(s, " class='small_font'", "")
    
36.         brr = Split(s, "</tr>")
    
37.         For i = 0 To UBound(brr) - 1
    
38.             Drr = Split(Replace(brr(i), "</td>", ""), "<td>")
    
39.             For j = 1 To UBound(Drr)
    
40.                 Sh.[h4].Offset(i, j) = Drr(j)
    
41.             Next j
    
42.         Next i
    
43. '        Call 方案一统计
    
44. '        Call 方案二统计
    
45. '        Call 方案三统计
    
46. '        Call 方案一H列数据统计
    
47. '        Call 方案二L列数据统计
    
48. '        Call 方案三P列数据统计
    
49. '    End If
    
50. End Sub

复制代码

提供地址:http://taobao.cjcp.com.cn/cjw11x ... 1ydj-11-3-1000.html
          这个错误地址也能提取数据,但不能更新.
真实地址:

1. http://taobao.cjcp.com.cn/cjw11x5/view/11x5qianerzs.php?searchType=2&xingType=2&lotteryType=11ydj&HighSelectYear=&HighSelectMonth=&HighSelectYangLi=&HighSelectYinLi=&HighSelectWeek=&HighSelectQishuEnd=&HighSelectQishujo=&HighSelectJQ=&HighSelectzu3=&HighSelectzu6=&HighSelectjiqiu=&Qishu=1000&button2=开始筛选"
   

复制代码

kjhgyujh

onlycxb 大师 可否分享下抓取网址中的邮箱

blanksoul12

網抓我本人很有興趣的,因工作上須要,但FIDDER內的資料不知怎運用套在VBA內

onlycxb

kjhgyujh 发表于 2014-10-15 17:07
onlycxb 大师 可否分享下抓取网址中的邮箱

可查阅outlook获取邮件相关内容!有兴趣可交流!
以下是近日写的一段代码,根据.mdb数据库内容,发送邮件.可参阅http://club.excelhome.net/forum. ... 3&page=1#pid7885877
Sub SendMail()
    Dim Conn As ADODB.Connection, rst As ADODB.Recordset, MyData As String, StrSql As String, arr
    Dim olApp As Object, oitem As Object, i%
    MyData = "db1.mdb"
    Set Conn = New ADODB.Connection
    Set rst = New ADODB.Recordset
    Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "\" & MyData
    If Conn.State = adStateOpen Then
        StrSql = "Select * From [CallLog] "
        rst.Open StrSql, Conn, adOpenStatic
    End If
    arr = Application.WorksheetFunction.Transpose(rst.GetRows)
    Set olApp = CreateObject("outlook.application")
    For i = 1 To UBound(arr, 1)
        If InStr(arr(i, 8), "返回按键") Then
            Set oitem = olApp.CreateItem(olMailItem)
            With oitem
                .Subject = ""  '这里主题,根据需要修改
                .To = ""        '发送地址,根据需要修改
                 .Body = arr(i, 2) & arr(i, 8)
                .Send
            End With
            Set oitem = Nothing
        End If
    Next i
    Set olApp = Nothing
End Sub
'以上代码假定数据库db1.mdb与代码文件在同一个文件夹内,可根据需要灵活修改

kjhgyujh

onlycxb 发表于 2014-10-15 17:27
可查阅outlook获取邮件相关内容!有兴趣可交流!
以下是近日写的一段代码,根据.mdb数据库内容,发送邮件.可 ...

outlook没有用过，代码百分之九十九看不懂。

blanksoul12

http://jiaoyi.sina.com.cn/jy/stock/ranking/
見有人問,但開FIDDER來看,沒看到任何關在網址後的分頁或分行碼,那請問怎拿下呢?

onlycxb

blanksoul12 发表于 2014-10-15 19:31
http://jiaoyi.sina.com.cn/jy/stock/ranking/
見有人問,但開FIDDER來看,沒看到任何關在網址後的分頁或分行 ...

复楼上，我是通过计算记录总数/每页20条记录得到总记录（代码中已经标注）。 网页数据地址为http://jiaoyi.sina.com.cn/api/js ... atio&ordertype=desc  其中，第一页 start为从0开始，第二页从20开始…………

分享6：

1. Sub 新浪模拟交易()
   
2. '网址：http://jiaoyi.sina.com.cn/jy/stock/ranking/
   
3. '要求：按照格式将1-5页排民各自选手的子项数据导入excel
   
4. '说明：以下代码仅演示提取"当前持昌数据表中的部分字段"
   
5. 
   
6.     Dim xml As New MSXML2.XMLHTTP, Js
   
7.     Dim Url$, st$, n%, i%, r%, j%, Total%, m%, k%
   
8.     Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
   
9.     Dim arr(1 To 100000, 1 To 13), brr, crr
   
10.     Dim Sid As String
    
11.    
    
12.    '第一次读取,取总记录数Total
    
13.     Set sht1 = Sheets("当日持仓")
    
14.     sht1.UsedRange.Offset(1, 0).Clear
    
15.     Url = "http://jiaoyi.sina.com.cn/api/jsonp.php/Johansen=johansen062308384298872741413371443299/Ranking_Service.getRate?cid=10000&num=20&start=0&orderby=profit_ratio&ordertype=desc&qjson="
    
16.     With xml
    
17.         .Open "GET", Url, False
    
18.         .send
    
19.         st = Split(Split(.responseText, "johansen062308384298872741413371443299((")(1), "))")(0)
    
20.     End With
    
21.     Set Js = CreateObject("scriptcontrol")
    
22.     Js.Language = "jscript"
    
23.     Js.AddCode ("dy=" & st)
    
24.     Total = Js.Eval("dy.total")                                           '37楼，这里取得记录数
    
25.    
    
26.     '利用总记录数进行循环,每页20条记录
    
27.     For i = 0 To 40 Step 20                           '为提高测试速度,这里暂取40(两页),实际可用Total代替40
    
28.         Url = "http://jiaoyi.sina.com.cn/api/jsonp.php/Johansen=johansen062308384298872741413371443299/Ranking_Service.getRate?cid=10000&num=20&start=" & i & "&orderby=profit_ratio&ordertype=desc&qjson="
    
29.         With xml
    
30.             .Open "GET", Url, False
    
31.             .send
    
32.             st = Split(Split(.responseText, "johansen062308384298872741413371443299((")(1), "))")(0)
    
33.         End With
    
34.         Js.AddCode ("dy=" & st)
    
35.         n = Js.Eval("dy.data.length")
    
36.         For j = 0 To n - 1
    
37.             Sid = Js.Eval("dy.data[" & j & "].sid")     '取得证券代码
    
38.             
    
39.            '利用代码进行代码的明细数据查询
    
40.             Url = "http://jiaoyi.sina.com.cn/api/jsonp_v2.php/jsonp_1413382356619_19604286/Stockhold_Service.getStockhold?"
    
41.             Url = Url + "sid=" & Sid
    
42.             Url = Url + "&cid=10000&count=10"
    
43.             xml.Open "GET", Url, False
    
44.             xml.send
    
45.             st = Split(Split(xml.responseText, "jsonp_1413382356619_19604286((")(1), "))")(0)
    
46.             Js.AddCode ("dy2=" & st)
    
47.             m = Js.Eval("dy2.count")
    
48.             
    
49.             On Error Resume Next
    
50.             For k = 0 To m - 1
    
51.             r = r + 1
    
52.                 arr(r, 1) = Js.Eval("dy.data[" & j & "].rank") '排名
    
53.                 arr(r, 2) = Js.Eval("dy.data[" & j & "].name") '昵称
    
54.                 arr(r, 3) = k + 1
    
55.                 arr(r, 4) = Js.Eval("dy2.data[" & k & "].StockName") & Chr(10) & "(" & Js.Eval("dy2.data[" & k & "].StockCode") & ")"
    
56.                 arr(r, 5) = Js.Eval("dy2.data[" & k & "].AvailSell")
    
57.                 arr(r, 6) = Js.Eval("dy2.data[" & k & "].StockAmount")
    
58.                 arr(r, 7) = Js.Eval("dy2.data[" & k & "].cost")
    
59.                 '......省略一些取值....方法同上'
    
60.             Next k
    
61.         Next j
    
62.     Next i
    
63.     sht1.[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
64. End Sub

复制代码

choesehae

师傅又出手啦!顶!

VBA万岁

onlycxb 发表于 2014-10-15 23:12
复楼上，我是通过计算记录总数/每页20条记录得到总记录（代码中已经标注）。 网页数据地址为http://jiaoy ...

测试通过，多谢分享！