Home > Mobile >  Unable to let a macro fetch tabular content issuing post http requests
Unable to let a macro fetch tabular content issuing post http requests

Time:03-18

I've been trying to get tabular content from a webpage using xmlhttp requests. I'm interested in the table populated upon clicking on the Player Interests tab. When I observe network activity I could learn that a post http requests along with appropriate parameters is issued to this url to get the required response. I tried to mimic the same using the following attempt but I always get this 0|error|500|| as response. However, I got required response when I follow the same logic in python.

How can I get tabular content from Player Interests tab? Please note that I didn't change anything in other dropdown options to populate the results manually.

Option Explicit
Public Sub GetContent()
    Const sBase = "https://www.perfectgame.org"
    Const Url$ = "https://www.perfectgame.org/College/CollegeCommitments.aspx?tab=interest"
    Dim oHtml As HTMLDocument, MyDict As Object
    Dim DictKey As Variant, payload$, oHttp As Object
    Dim HTML As HTMLDocument

    Set HTML = New HTMLDocument
    Set oHtml = New HTMLDocument
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    Set MyDict = CreateObject("Scripting.Dictionary")
    
    With oHttp
        .Open "GET", Url, True
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
        .send
        While .readyState < 4: DoEvents: Wend
        oHtml.body.innerHTML = .responseText
    End With

    MyDict("ctl00$ctl00$ScriptManager2") = "ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$MainUpdatePanel|ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$lbInterest"
    MyDict("__EVENTTARGET") = "ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$lbInterest"
    MyDict("__EVENTARGUMENT") = ""
    MyDict("__LASTFOCUS") = ""
    MyDict("__VIEWSTATE") = oHtml.getElementById("__VIEWSTATE").Value
    MyDict("__VIEWSTATEGENERATOR") = oHtml.getElementById("__VIEWSTATEGENERATOR").Value
    MyDict("__EVENTVALIDATION") = oHtml.getElementById("__EVENTVALIDATION").Value
    MyDict("ctl00$ctl00$ContentTopLevel$HeaderTop$ghtys") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$HeaderTop$tbGreen") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$HeaderTop$tbDarkBlue") = ""
    MyDict("ctl00_ctl00_ContentTopLevel_ContentPlaceHolder1_ucCommitMenu_radsocialProfile_ClientState") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$ddlYear") = "2022"
    MyDict("ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$ddlDivision") = "D1"
    MyDict("ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$ddlColleges") = "1756"
    MyDict("ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$ddlStates") = "0"
    MyDict("ctl00$ctl00$ContentTopLevel$ContentPlaceHolder1$radgInterests$ctl00$ctl03$ctl01$PageSizeComboBox") = "50"
    MyDict("ctl00_ctl00_ContentTopLevel_ContentPlaceHolder1_radgInterests_ctl00_ctl03_ctl01_PageSizeComboBox_ClientState") = ""
    MyDict("ctl00_ctl00_ContentTopLevel_ContentPlaceHolder1_radgInterests_ClientState") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$Footer1$rcbPGSpecialEvents") = "PG Special Events"
    MyDict("ctl00_ctl00_ContentTopLevel_Footer1_rcbPGSpecialEvents_ClientState") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$Footer1$rcbTravel") = "Travel, Lodging, Entertainment"
    MyDict("ctl00_ctl00_ContentTopLevel_Footer1_rcbTravel_ClientState") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$Footer1$rcbPartners") = "PG Partners"
    MyDict("ctl00_ctl00_ContentTopLevel_Footer1_rcbPartners_ClientState") = ""
    MyDict("ctl00$ctl00$ContentTopLevel$Footer1$rcbRecommended") = "Recommended"
    MyDict("ctl00_ctl00_ContentTopLevel_Footer1_rcbRecommended_ClientState") = ""
    MyDict("ctl00$ctl00$hfpagetype") = ""
    MyDict("ctl00$ctl00$hfpassingid") = ""
    MyDict("ctl00$ctl00$hfsport") = ""
    MyDict("ctl00$ctl00$hfstate") = ""
    MyDict("ctl00$ctl00$hfzipcodes") = ""
    MyDict("hiddenInputToUpdateATBuffer_CommonToolkitScripts") = "1"
    MyDict("__ASYNCPOST") = "true"
    
    payload = ""
    For Each DictKey In MyDict
        On Error Resume Next
        payload = IIf(Len(DictKey) = 0, Application.EncodeURL(DictKey) & "=" & Application.EncodeURL(MyDict(DictKey)), _
        payload & "&" & Application.EncodeURL(DictKey) & "=" & Application.EncodeURL(MyDict(DictKey)))
        On Error GoTo 0
    Next DictKey

    With oHttp
        .Open "POST", Url, True
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/99.0.4844.51 Safari/537.36"
        .setRequestHeader "Content-type", "application/x-www-form-urlencoded; charset=UTF-8"
        .setRequestHeader "Host", "www.perfectgame.org"
        .setRequestHeader "Origin", "https://www.perfectgame.org"
        .setRequestHeader "Referer", "https://www.perfectgame.org/College/CollegeCommitments.aspx"
        .setRequestHeader "X-MicrosoftAjax", "Delta=true"
        .setRequestHeader "X-Requested-With", "XMLHttpRequest"
        .setRequestHeader "Accept", "*/*"
        .setRequestHeader "accept-Encoding", "gzip , deflate, br"
        .send (payload)
        While .readyState < 4: DoEvents: Wend
        Debug.Print .responseText
        HTML.body.innerHTML = .responseText
        MsgBox HTML.querySelector("table[id='ctl00_ctl00_ContentTopLevel_ContentPlaceHolder1_radgCommitment_ctl00'] tbody tr[class*='Row']").innerText
    End With
    
End Sub

CodePudding user response:

I was able to get it working by commenting out this line:

.setRequestHeader "Content-type", "application/x-www-form-urlencoded; charset=UTF-8"

CodePudding user response:

I'm assuming you are interested in the table with the id ctl00_ctl00_ContentTopLevel_ContentPlaceHolder1_radgInterests_ctl00.

I can fetch that table with the below code:

Sub Test()
    Const url As String = "https://www.perfectgame.org/College/CollegeCommitments.aspx?tab=interest"
    
    Dim xmlhttp As XMLHTTP60
    Set xmlhttp = New XMLHTTP60
    
    xmlhttp.Open "GET", url, False
    xmlhttp.send
    
    Dim htmldoc As HTMLDocument
    Set htmldoc = New HTMLDocument
    htmldoc.body.innerHTML = xmlhttp.responseText
    
    Debug.Print Not htmldoc.getElementById("ctl00_ctl00_ContentTopLevel_ContentPlaceHolder1_radgInterests_ctl00") Is Nothing
End Sub
  • Related