racla Web folosind XHR de la siriusxm.com

voturi
1

Am nevoie pentru a trage artistul joacă în prezent și cântecul din http://www.siriusxm.com/siriusxmhits1 . Pot obține acest lucru navigarea pe site - ul cu Internet Explorer , dar este nevoie de prea mult timp , așa că am încercat , folosind WINHTTP.WinHTTPRequest.5.1și , MSXML2.serverXMLHTTPdar nici nu trage datele specifice caut. Cred că sunt aproape , dar am lipsește ceva.

Mai jos este fragmentul 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>

Aici este codul meu curent:

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

Dacă activez Internet Explorer se va lucra folosind urmatorul cod, dar care durează prea mult pentru ceea ce am nevoie să fac:

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
Întrebat 09/04/2017 la 20:34
sursa de către utilizator
În alte limbi...                            


1 răspunsuri

voturi
0

Site - ul http://www.siriusxm.com are un fel de un API disponibile. Am navigat o pagină de link - ul http://www.siriusxm.com/hits1 în Chrome, apoi a deschis fereastra Instrumente de dezvoltare ( F12), fila Rețea și a examinat XHRs în listă. Info melodie curente pot fi recuperate de exemplu , în următoarele etape:

Mai jos este proba care prezintă structura de răspuns JSON, am folosi instrument online http://jsonviewer.stack.hu :

răspuns JSON

Aveți dreptul să utilizați codul VBA de mai jos pentru a prelua informatiile așa cum este descris mai sus. Import JSON.bas modul în proiectul VBA pentru prelucrare 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

BTW, aceeași abordare folosită în acest , aceasta și aceste răspunsuri.

Publicat 29/04/2017 la 02:28
sursa de către utilizator

Cookies help us deliver our services. By using our services, you agree to our use of cookies. Learn more