如何用vba更新腾讯分分彩、腾讯时时彩开奖结果？

腾讯分分彩、腾讯时时彩是一种以QQ在线人数的计算结果作为开奖结果的彩种。

在腾讯的官网https://im.qq.com/的页面右上角有实时的QQ同时在线总人数。

比如现在的在线总人数是26915492，那么开奖结果就是85492。

其中5492为在线总人数的最后4位数字，8为在线总人数的所有位数的和的个位数，也就是2+6+9+1+5+4+9+2的和38的个位数8。

由于这个在线总人数是一直变化的，如果每分钟更新一次，就可以每分钟出一次结果，腾讯分分彩的原理就是如此。

为了实现腾讯分分彩的每期开奖结果的实时更新，可以找到类似的统计QQ在线总人数的网页，利用网络抓取的方法获得在线总人数，然后根据上述的原理计算出开奖结果。

本文介绍用WinHttpRequest对象通过采集http://www.77tj.org/tencent/网址的数据来更新腾讯分分彩的数据：

Sub QQ1722187970()
    Excel.Application.ScreenUpdating = False
    Excel.Application.Calculation = xlCalculationManual
    Set oHtml = CreateObject("htmlfile")
    Set ohttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    Dim sPostData As String
    arr = Array("期数", "开奖号码", "万千", "万百", "万十", "万个", "千百", "千十", "千个", "百十", "百个", "十个")
    Dim oWK As Worksheet
    Set oWK = Excel.Worksheets("Sheet1")
    With oWK
        .Cells.Clear
        Range("a1").Resize(1, UBound(arr) + 1) = arr
    End With
        oWK.Range("B1").EntireColumn.NumberFormat = "@"
        sUrl = "http://www.77tj.org/tencent/"
        With ohttp
            .Open "GET", sUrl, False
            .send
            sResult = Transcode(.responseBody, "utf-8")
        End With
        oHtml.body.innerHTML = sResult
        Set oElement = oHtml.getElementsByTagName("input")(1)
        sToken = oElement.Value
        Debug.Print sToken
        '每页15个数据，总共要遍历几页
        iSum = 5 * 15
        For n = 1 To iSum / 15
            sPostData = "PageIndex=" & n & "&__RequestVerificationToken=" & sToken
            Debug.Print sPostData
            With ohttp
                .Open "POST", sUrl, False
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                .send (sPostData)
                sResult = Transcode(.responseBody, "utf-8")
            End With
            iROW = oWK.Range("a" & oWK.Rows.Count).End(xlUp).Row + 1
            oHtml.body.innerHTML = sResult
            Set oTable = oHtml.getElementsByTagName("table")(0)
            Set oElement = oHtml.getElementsByTagName("input")(1)
            sToken = oElement.Value
            '逐行逐单元格提取
            With oTable
                Set oRow = .Rows
                For i = 1 To oRow.Length - 1
                    Set oCell = oRow(i).Cells
                    For j = 0 To oCell.Length - 2
                        oWK.Cells(iROW, j + 1) = oCell(j).innertext
                    Next j
                    iROW = iROW + 1
                Next i
            End With
        Next n
        '开始生成腾讯分分彩开奖号码
    With oWK
        For i = 2 To .Range("a65536").End(xlUp).Row
            tSum = 0
            sValue = 1 * .Cells(i, "b")
            For j = 1 To Len(sValue)
                tSum = VBA.Val(Mid(sValue, j, 1)) + tSum
            Next j
           sKJHM = Right(tSum, 1) & Right(sValue, 4)
           .Cells(i, "B") = sKJHM
        Next i
        '开始计算龙虎和
        .Cells(2, "C").FormulaR1C1 = "=TEXT(MID(RC2,5,1)-MID(RC2,4,1),""龙;虎;和"")"
        .Cells(2, "D").FormulaR1C1 = "=TEXT(MID(RC2,5,1)-MID(RC2,3,1),""龙;虎;和"")"
        .Cells(2, "E").FormulaR1C1 = "=TEXT(MID(RC2,5,1)-MID(RC2,2,1),""龙;虎;和"")"
        .Cells(2, "F").FormulaR1C1 = "=TEXT(MID(RC2,5,1)-MID(RC2,1,1),""龙;虎;和"")"
        .Cells(2, "G").FormulaR1C1 = "=TEXT(MID(RC2,4,1)-MID(RC2,3,1),""龙;虎;和"")"
        .Cells(2, "H").FormulaR1C1 = "=TEXT(MID(RC2,4,1)-MID(RC2,2,1),""龙;虎;和"")"
        .Cells(2, "I").FormulaR1C1 = "=TEXT(MID(RC2,4,1)-MID(RC2,1,1),""龙;虎;和"")"
        .Cells(2, "J").FormulaR1C1 = "=TEXT(MID(RC2,3,1)-MID(RC2,2,1),""龙;虎;和"")"
        .Cells(2, "K").FormulaR1C1 = "=TEXT(MID(RC2,3,1)-MID(RC2,1,1),""龙;虎;和"")"
        .Cells(2, "L").FormulaR1C1 = "=TEXT(MID(RC2,2,1)-MID(RC2,1,1),""龙;虎;和"")"
        .Range("c2:l2").AutoFill Destination:=.Range("C2:L51"), Type:=xlFillDefault
        Excel.Application.Calculation = xlCalculationAutomatic
        .Range("c2:L51").Copy
        Sheet2.Range("c2").PasteSpecial xlPasteAll
        .Range("a1:b51").Copy
        Sheet2.Range("a1").PasteSpecial xlPasteAll
        Sheet2.Columns.AutoFit
        .Range("c1:L51").Clear
        .Columns.AutoFit
    End With
    Excel.Application.ScreenUpdating = True
End Sub