网页提取

学不完用不尽

看了论坛里有关网页提取的帖子，模仿了一下，还是搞不懂，望用"Msxml2.XMLHTTP"方法示范一下，谢谢！
要求：
提取下面网页中最近100期的“期号”、“开奖日期”和“奖池”三列数据，写入工作表后按升序排序。
http://chart.cp.360.cn/kaijiang/ ... d1a3c8981eea636b068

liucqa

http://chart.cp.360.cn/kaijiang/ ... 160357816834#roll_0

数据都在table(0)里面，可以直接取

suwenkai

1. Sub t()
   
2.     Dim url
   
3.     url = "http://chart.cp.360.cn/kaijiang/qxc?lotId=110022&spanType=0&span=" & [e1] & "&r=0.59452286923828"
   
4.     Set HTML = CreateObject("htmlfile")
   
5.     With CreateObject("msxml2.xmlhttp")
   
6.         .Open "get", url, False
   
7.         .send
   
8.         tt = BytesToBstr(.ResponseBody, "GB2312")
   
9.         HTML.body.innerhtml = tt
   
10.     End With
    
11. 
    
12.     Set tb = HTML.all.tags("table")(1).Rows
    
13.     Sheet1.UsedRange.Offset(2).ClearContents
    
14.     For i = 2 To tb.Length - 1
    
15.             If i >= 2 Then
    
16.             Cells(i, 1) = tb(i).Cells(0).innertext
    
17.             Cells(i, 2) = tb(i).Cells(1).innertext
    
18.             Cells(i, 3) = tb(i).Cells(8).innertext
    
19.             End If
    
20.     Next
    
21. End Sub
    
22. Function BytesToBstr(strBody, CodeBase)         '使用Adodb.Stream对象提取字符串
    
23.     Dim objStream
    
24.     On Error Resume Next
    
25.     Set objStream = CreateObject("Adodb.Stream")
    
26.     With objStream
    
27.         .Type = 1                               '二进制
    
28.         .Mode = 3                               '读写
    
29.         .Open
    
30.         .Write strBody                          '二进制数组写入Adodb.Stream对象内部
    
31.         .Position = 0                           '位置起始为0
    
32.         .Type = 2                               '字符串
    
33.         .Charset = CodeBase                     '数据的编码格式
    
34.         BytesToBstr = .ReadText                 '得到字符串
    
35.     End With
    
36.     objStream.Close
    
37.     Set objStream = Nothing
    
38.     If Err.Number <> 0 Then BytesToBstr = ""
    
39.     On Error GoTo 0
    
40. End Function
    

复制代码

学不完用不尽

liucqa 发表于 2014-3-2 12:38
http://chart.cp.360.cn/kaijiang/qxc?lotId=110022&spanType=0&span=100&r=0.9777160357816834#roll_0

...

行家一出手，便知有没有。
谢谢！

学不完用不尽

suwenkai 发表于 2014-3-2 12:45

谢谢！
赞一个！

ccwan

取100期的

1. Sub cc()
   
2.     Cells.ClearContents
   
3.     url = "http://chart.cp.360.cn/kaijiang/qxc?lotId=110022&spanType=0&span=100&r=0.6718537958201473#roll_0"
   
4.     Set oDoc = CreateObject("htmlfile")
   
5.     With CreateObject("msxml2.xmlhttp")
   
6.         .Open "get", url, False
   
7.         .send
   
8.         oDoc.body.innerHTML = StrConv(.responsebody, vbUnicode)
   
9.     End With
   
10.     Set r = oDoc.All.tags("table")(1).Rows
    
11.     For i = 1 To r.Length - 1
    
12.         For j = 0 To r(i).Cells.Length - 8
    
13.             Cells(i, j + 1) = r(i).Cells(j).innerText
    
14.         Next j
    
15.     Next i
    
16. End Sub

复制代码

学不完用不尽

ccwan 发表于 2014-3-2 14:06
取100期的

谢谢！赞一个！
不使用自定义函数而使用strconv函数来转换网页编码。

YZC51

取1000期

1. Sub test1()
   
2.     Set myQuery = ActiveSheet.QueryTables.Add(Connection:="URL;http://chart.cp.360.cn/kaijiang/qxc?lotId=110022&spanType=0&span=1000&r=0.9777160357816834#roll_0/", Destination:=[a1])
   
3.     myQuery.Refresh
   
4.     [1:3].Delete
   
5. End Sub
   

复制代码

YZC51

或

1. Sub test1()
   
2.     Set myQuery = ActiveSheet.QueryTables.Add(Connection:="URL;http://chart.cp.360.cn/kaijiang/qxc?lotId=110022&spanType=0&span=1000&r=0.9777160357816834#roll_0/", Destination:=[a1])
   
3.     myQuery.Refresh
   
4.     [1:3].Delete
   
5.     [C:C].Font.Color = -16776961
   
6. End Sub

复制代码

学不完用不尽

YZC51 发表于 2015-10-25 11:15
或

这四行代码，取不出数据！
貌似需要设置等待时间。