使用来自siriusxm.com的XHR进行网页扫描

Question

我需要从http://www.siriusxm.com/siriusxmhits1中拉出当前播放的艺术家和歌曲。我可以通过Internet Explorer浏览到这个网站，但这需要很长时间，所以我尝试使用WINHTTP.WinHTTPRequest.5.1和MSXML2.serverXMLHTTP，但都没有提取我正在寻找的特定数据。我觉得我很接近，但是错过了一些东西。

下面是HTML片段：

<div id="on-the-air-content" style="display: block;"> 
    <div class="module-content theme-color-content-bg clearfix"> 
     <div id="onair-pdt" style="display: block;"> 
      <img alt="" src="//www.siriusxm.com/albumart/Live/2000/chainsmokers_58C328AC_t.jpg"> 
      <p class="onair-pdt-artist">Chainsmokers/Coldplay</p> 
      <p class="onair-pdt-song">Something Just Like This</p> 
     </div> 
     ... 
    </div> 
    ... 
</div> 

这里是我当前的代码：

Sub GetData() 

    Dim getArtist As Object 
    Dim getSong As Object 

    Set xmHtml = New HTMLDocument 
    With CreateObject("WINHTTP.WinHTTPRequest.5.1") 
     .Open "GET", "http://www.siriusxm.com/siriusxmhits1", False 
     .send 
     xmHtml.body.innerHTML = .responseText 
    End With 
    Set getArtist = xmHtml.getElementById("onair-pdt").getElementsByTagName("p")(0) 
    MsgBox (getArtist.innerText) 
    Set getSong = xmHtml.getElementById("onair-pdt").getElementsByTagName("p")(1) 
    MsgBox (getSong.innerText) 

End Sub 

如果我启动Internet Explorer中，将工作使用下面的代码，但时间太长了什么我需要做的：

Sub GetData() 

    Dim DivID As HTMLObjectElement 
    Dim getArtist As Variant 
    Dim getSong As Variant 

    URL = "http://www.siriusxm.com/siriusxmhits1" 
    With IExplore 
     .Navigate URL 
     .Visible = False 
     Do While .readyState <> 4: DoEvents: Loop 
     Set doc = .document 
     Set DivID = doc.getElementById("onair-pdt") 
     getArtist = DivID.getElementsByClassName("onair-pdt-artist")(0).innerText 
     getSong = doc.getElementsByClassName("onair-pdt-song")(0).innerText 
    End With 

End Sub 

Answer 1

网站http://www.siriusxm.com有一种A PI可用。我浏览Chrome浏览器中的链接http://www.siriusxm.com/hits1，然后打开开发工具窗口（F12），网络选项卡，并检查列表中的XHR。当前歌曲信息可以被检索e。 G。通过以下步骤：

• 通过URL http://www.siriusxm.com/sxm_date_feed.tzi制作XHR以检索当前时间戳。在URL http://www.siriusxm.com/metadata/pdt/en-us/json/channels/siriushits1/timestamp/04-29-02:02:55

• 解析的最后数量使用当前时间戳

• 制作XHR收到JSON响应。

• 获取歌曲的名称为JSON.channelMetadataResponse.metaData.currentEvent.song.name，艺术家JSON.channelMetadataResponse.metaData.currentEvent.artists.name等

下面是示例显示JSON响应结构，我使用的在线工具http://jsonviewer.stack.hu：

您可能如上所述，使用下面的VBA代码来检索信息。 将JSON.bas模块导入JSON处理的VBA项目。

Option Explicit 

Sub Test_siriusxm_com() 

    Dim s As String 
    Dim d As Date 
    Dim sUrl As String 
    Dim vJSON As Variant 
    Dim sState As String 
    Dim sArtists As String 
    Dim sComposer As String 
    Dim sAlbum As String 
    Dim sSong As String 

    ' Retrieve timestamp 
    With CreateObject("MSXML2.XMLHTTP") 
     .Open "GET", "http://www.siriusxm.com/sxm_date_feed.tzi", False 
     .send 
     s = .responseText 
    End With 
    ' Parse timestamp to Date type 
    d = CDate(DateSerial(Mid(s, 5, 4), Mid(s, 3, 2), Mid(s, 1, 2)) + TimeSerial(Mid(s, 9, 2), Mid(s, 11, 2), Mid(s, 13, 2))) 
    ' Add 4 hours to get UTC from EDT timezone 
    d = DateAdd("h", 4, d) 
    ' Combine URL with timestamp 
    sUrl = "http://www.siriusxm.com/metadata/pdt/en-us/json/channels/siriushits1/timestamp/" & _ 
      LZ(Month(d), 2) & "-" & _ 
      LZ(Day(d), 2) & "-" & _ 
      LZ(Hour(d), 2) & ":" & _ 
      LZ(Minute(d), 2) & ":" & _ 
      "00" 
    ' Retrieve channelMetadataResponse JSON data 
    With CreateObject("MSXML2.XMLHTTP") 
     .Open "GET", sUrl, False 
     .send 
     s = .responseText 
    End With 
    ' Parse JSON response 
    JSON.Parse s, vJSON, sState 
    ' Check if valid 
    If sState <> "Object" Then 
     MsgBox "Invalid JSON response" 
     Exit Sub 
    End If 
    ' Check if available 
    If vJSON("channelMetadataResponse")("messages")("code") <> "100" Then 
     MsgBox "Unavailable content" 
     Exit Sub 
    End If 
    ' Get necessary properties 
    Set vJSON = vJSON("channelMetadataResponse")("metaData")("currentEvent") 
    sArtists = vJSON("artists")("name") 
    sComposer = vJSON("song")("composer") 
    sAlbum = vJSON("song")("album")("name") 
    sSong = vJSON("song")("name") 
    ' Output results 
    MsgBox "On the Air" & vbCrLf & _ 
     "Artists: " & sArtists & vbCrLf & _ 
     "Composer: " & sComposer & vbCrLf & _ 
     "Album: " & sAlbum & vbCrLf & _ 
     "Song: " & sSong 

End Sub 

Function LZ(n As String, q As Long) As String ' Add leading zeroes 
    LZ = Right(String(q, "0") & n, q) 
End Function 

顺便说一句，在this，this和this答案使用相同的方法。