html - Raspado web usando XHR de siriusxm.com

vba excel-vba

Question

Necesito obtener el artista y la canción que se está reproduciendo actualmente en http://www.siriusxm.com/siriusxmhits1 . Puedo hacer que esto funcione al navegar por el sitio web con Internet Explorer, pero lleva demasiado tiempo, así que he intentado usar WINHTTP.WinHTTPRequest.5.1 y MSXML2.serverXMLHTTP pero ninguno MSXML2.serverXMLHTTP los datos específicos que estoy buscando. Creo que estoy cerca pero me falta algo.

A continuación se muestra el fragmento de 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>

Aquí está mi código actual:

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

Si activo Internet Explorer, funcionará con el siguiente código, pero eso toma demasiado tiempo para lo que necesito hacer:

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

El sitio web http://www.siriusxm.com tiene una especie de API disponible. Navegué una página por el enlace http://www.siriusxm.com/hits1 en Chrome, luego abrí la ventana Herramientas para desarrolladores ( F12 ), la pestaña Red y examiné los XHR en la lista. La información de la canción actual se puede recuperar, por ejemplo, en los siguientes pasos:

• Haga XHR por URL http://www.siriusxm.com/sxm_date_feed.tzi para recuperar la marca de tiempo actual.

• Haga XHR usando la marca de tiempo actual en los últimos números de URL http://www.siriusxm.com/metadata/pdt/en-us/json/channels/siriushits1/timestamp/04-29-02:02:55

• Parse recibió la respuesta de JSON.

• Obtenga el nombre de la canción como JSON.channelMetadataResponse.metaData.currentEvent.song.name , artistas como JSON.channelMetadataResponse.metaData.currentEvent.artists.name , etc.

A continuación se muestra el ejemplo que muestra la estructura de respuesta JSON. Utilizo la herramienta en línea http://jsonviewer.stack.hu :

Puede usar el siguiente código de VBA para recuperar información como se describe anteriormente. Importe el módulo JSON.bas al proyecto VBA para el procesamiento JSON.

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

Por cierto, el mismo enfoque utilizado en this , this y this responde.