重庆时时彩自动更新号码模板（网站再次升级后）-- The Latest Version

kangatang

我为什么要发这个贴？因为彩票比较热门，关注的人多，换句话就是应用性强。比如跟12306火车票搭点边就火。
在论坛中有些技术含量很高的帖子，但是没有被热门，就冷落在论坛某个角落里。

本帖无技术含量，不是用来学习的，只是急大家所需。

数据采集自重庆时时彩：http://data.shishicai.cn/cqssc/haoma/
网站升级后，有防盗链限制，而且必须要Cookie提交。原先的方法不能用，现帮大家更新。附件如下 (附件中有XMLHTTP和IE两种方法)
重庆时时彩自动更新号码.zip (24.12 KB, 下载次数: 2227)

2013-1-19 17:24 上传

点击文件名下载附件

代码如下：
Sub Quick_refresh()
Dim cookies, arr As Variant, XML As Object
Set XML = CreateObject("WinHttp.WinHttpRequest.5.1") '("Msxml2.XMLHTTP.5.0")
With XML
'获取COOKIE - START
      .Open "GET", "http://data.shishicai.cn/cqssc/haoma/", False
      .Send
      cookies = Split(.getallResponseHeaders(), "Set-Cookie: ")
      For i = LBound(cookies) + 1 To UBound(cookies)
            ckvalue = IIf(ckvalue = "", Split(cookies(i), ";")(0), ckvalue + "; " + Split(cookies(i), ";")(0))
      Next
'获取COOKIE - END
     .Open "POST", "http://data.shishicai.cn/handler/kuaikai/data.ashx", False
     .setRequestHeader "Referer", "http://data.shishicai.cn/cqssc/haoma/"
     .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
     .setRequestHeader "Cookie", ckvalue
     .Send "lottery=4&date=0001-01-01"
      lotsdata = Replace(Split(Split(.responsetext, "[")(1), "]")(0), """", "")
      arr = Split(lotsdata, ",")
      Columns("A:C").ClearContents
      Range(Cells(1, 1), Cells(1, 3)).Value = Array("期号", "开奖号码", "开奖时间")
      For i = LBound(arr) To UBound(arr)
           Range(Cells(i + 2, 1), Cells(i + 2, 3)).Value = Split(arr(i), ";")
      Next
End With
Set XML = Nothing
MsgBox "OK"
End Sub

kangatang

关于防盗链的解释见
http://club.excelhome.net/thread-951777-1-1.html

CLTZGS

谢谢楼主分享！大力顶。。。。。。。。。

kangatang

这网站没几天就变花样，附件又得更新。有空再说

bav99

感谢楼主，顶一下{:soso_e179:}

叶春晖

楼主真好人也！ 爱斯你了~{:soso_e163:}{:soso_e163:}{:soso_e163:}，，，同时希望楼主可以改一下代码，把期数往下排列，就完美了

where001

楼主真是救星呀！
但还有一建议：是否可实现指定日期开奖结果获取呢？
谢谢！！

蓝天630902

叶春晖 发表于 2013-2-3 18:52
楼主真好人也！ 爱斯你了~，，，同时希望楼主可以改一下代码，把期 ...

Sub 重庆时时彩()
    On Error Resume Next
    Dim arr
    With CreateObject("Microsoft.XMLDOM")
        .async = False
        .Load "http://500wan.zone.tenpay.com/static/public/ssc/xml/historyopen.xml"
        s = .DocumentElement.ChildNodes.Length
        ReDim arr(0 To s, 0 To 6)
        For i = 0 To .DocumentElement.ChildNodes.Length - 1
            Set r = .DocumentElement.ChildNodes.Item(i)
            For J = 0 To r.Attributes.Length - 1
                arr(i, J) = r.Attributes.Item(J).Text
            Next J
        Next i
    End With
    Range(Cells(1, "a"), Cells(s, "F")) = arr
End Sub

kangatang

蓝天630902 发表于 2013-2-23 18:17
Sub 重庆时时彩()
    On Error Resume Next
    Dim arr

谢谢您的回复

soshewo

很好謝謝..........