VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 155|回复: 1

[分享] 《网易薄荷直播》获得主播数据的源码分享

[复制链接]
发表于 2018-10-20 10:53:06 | 显示全部楼层 |阅读模式

我在网易看新闻的时候,收到一个推送消息,是它旗下的一个直播平台叫《网易薄荷直播》,现在直播正火,我看了一下,里面的观众比主播有意思,而且有很多各种类型程序员在里面玩(有大神级别的程序员),有个欧洲的程序员(华人)写了一个24小时自动帮助主播的程序,挺有意思。
正好现在都是网络的天下,正好通过做个学习一下网络知识,我分析了一下网页的数据,挺有意思。已经解决UTF8转码,JSON数据获取。。。。
目前未解决的问题:winHttp在POST数据时的Cookie处理




Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Private Const CP_ACP = 0        ' default to ANSI code page
Private Const CP_UTF8 = 65001   ' default to UTF-8 code page
Private Sub Command1_Click()
Dim zhuboInfo As String
Dim tmp As String
'获得网页源码
outerHTML = getLiveHtml("http://live.ent.163.com")

'从源码中提取主播信息
zhuboInfo = GetKeyWordMid(outerHTML, "decodeURIComponent(" & Chr(34), ");", 1000)

'对主播信息解码
tmp = decodeURIC(zhuboInfo)

'主播分组
arrtext = Split(tmp, "{" & Chr(34) & "type")

'打印数据
For i = 0 To UBound(arrtext)
Debug.Print i, "直播间ID="; GetKeyWordMid(arrtext(i), "roomId" & Chr(34), ","), "主播昵称="; GetKeyWordMid(arrtext(i), "nick" & Chr(34), ","), "收入="; GetKeyWordMid(arrtext(i), "Contribution" & Chr(34), ",")
Next
End Sub




'----------内部自定义函数-------------

Private Function getLiveHtml(ByVal strURL As String) As String
'载入链接地址中的网页

'Dim sTime As Long, OutTime As Long
Dim Body As String
Dim objXMLHTTP As Object
Dim State As Long
On Error Resume Next

'OutTime = 30& * 1000 '超时时间

Set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objXMLHTTP.Open "GET", strURL, False
objXMLHTTP.Send

'Call WaitSleep(400)

Do
   
    State = -1
    State = objXMLHTTP.ReadyState
    DoEvents
    If State = 4 Then
'        Body = ByteToStr(objXMLHTTP.ResponseBody, "gb2312")
        Body = ByteToUTF8(objXMLHTTP.ResponseBody)
        Exit Do
    End If

Loop 'Until GetTickCount - sTime > OutTime
getLiveHtml = Body
End Function
Private Function decodeURIC(strText As String) As String
'url转码:
'javascript提供了六个转码函数:escape,unescape,encodeURI,encodeURIComponent,decodeURI,decodeURIComponent
'最常用的是encodeURIComponent
'Debug.Print "decodeURIComponent('" & strText & "');"
On Error Resume Next
    Dim tmpStr As String
    With CreateObject("msscriptcontrol.scriptcontrol")
        .Language = "JavaScript"
        
        tmpStr = .Eval("decodeURIComponent('" & strText & "');")
    End With
    If Len(tmpStr) = 0 Then
        tmpStr = Utf8DecodeUnicode(strText)
    End If
   
    decodeURIC = tmpStr
End Function
Private Function ByteToUTF8(arrByte) As String
Dim objAdodbStream As Object
Set objAdodbStream = CreateObject("Adodb.Stream")
With objAdodbStream
    .Type = 1 'adTypeBinary
    .Open
    .Write arrByte
    .Position = 0
    .Type = 2 'adTypeText
    .Charset = "utf-8"
     ByteToUTF8 = .ReadText
    .Close
End With
End Function
Private Function Utf8DecodeUnicode(ByRef strURL As String) As String
'utf8字符转换为Unicode编码
    Dim tmpStr As String
    Dim i As Long, j As Long
    Dim arrStr() As Byte
    If InStr(strURL, "%") = 0 Then
        Utf8DecodeUnicode = strURL
        Exit Function
    End If
    ReDim arrStr(Len(strURL))
    For i = 1 To Len(strURL)
        If Mid(strURL, i, 1) = "%" Then
            arrStr(j) = Val("&H" & Mid(strURL, i + 1, 2))
                i = i + 2
                j = j + 1
            Else
                arrStr(j) = Asc(Mid(strURL, i, 1))
                j = j + 1
        End If
    Next
    ReDim Preserve arrStr(j - 1)
    Utf8DecodeUnicode = Utf8ToUnicode(arrStr)
End Function
Private Function Utf8ToUnicode(ByRef Utf() As Byte) As String
    Dim lRet As Long
    Dim lLength As Long
    Dim lBufferSize As Long
    lLength = UBound(Utf) - LBound(Utf) + 1
    If lLength <= 0 Then Exit Function
    lBufferSize = lLength * 2
    Utf8ToUnicode = String$(lBufferSize, Chr(0))
    lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)
    If lRet <> 0 Then
        Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
    End If
End Function
Private Function GetKeyWordMid(InputStr, StrKey1 As String, StrKey2 As String, Optional Start As Long = 1) As String
Dim nLen As Long
Dim nFind1 As Long
Dim nFind2 As Long
nLen = Len(InputStr)
nFind1 = InStr(Start, InputStr, StrKey1) '
nFind2 = InStr(nFind1 + 1, InputStr, StrKey2) '
If nFind1 > 0 And nFind2 - nFind1 > 1 Then '
    GetKeyWordMid = Mid(InputStr, nFind1 + Len(StrKey1), nFind2 - nFind1 - Len(StrKey1))
End If
End Function
 楼主| 发表于 2018-10-20 10:58:58 | 显示全部楼层
如果有谁解决了薄荷winHttp在POST数据时的Cookie处理,希望能分享一下
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2018-11-16 13:52

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表