Press A Button On A Webpage Using Vba And Without Opening Ie

I was wondering if it is possible to 'click a button' on a webpage without opening the page in IE. The webpage is dynamically generated and the click on the button calls a script t

Solution 1:

Consider the below example:

Option Explicit

Sub TestDownload()

    Dim strParams As String
    Dim strURL As String
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim arrScommessaList() As Variant
    Dim varScommessa As Variant

    strParams =Join(Array( _
        "p_p_id=ScommesseAntepostPalinsesto_WAR_scommesseportlet", _
        "p_p_lifecycle=2", _
        "p_p_state=normal", _
        "p_p_resource_id=dettagliManifestazione", _
        "p_p_cacheability=cacheLevelPage", _
        "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codDisc=1", _
        "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codMan=21", _
        "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codClusterScomm=", _
        "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_filtro=0" _
    ), "&")
    strURL = "http://www.sisal.it/scommesse-matchpoint/palinsesto?" & strParams

    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", strURL, False
        .Send
        strJsonString = .ResponseText
    EndWith

    ParseJson strJsonString, varJson, strState

    arrScommessaList = varJson("scommessaList")
    ForEach varScommessa In arrScommessaList
        Debug.Print varScommessa("descrizioneAvvenimento")
        Debug.Print vbTab & _
        varScommessa("esitoList")(0)("formattedQuota") & vbTab & _
        varScommessa("esitoList")(1)("formattedQuota") & vbTab & _
        varScommessa("esitoList")(2)("formattedQuota")
    Next

End Sub

Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
    ' strContent - source JSON string
    ' varJson - created object orarrayto be returned asresult' strState - Object|Array|Error depending on processing to be returned as state
    Dim objTokens As Object
    Dim lngTokenId As Long
    Dim objRegEx As Object
    Dim bMatched As Boolean

    Set objTokens = CreateObject("Scripting.Dictionary")
    lngTokenId = 0
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        ' specification http://www.json.org/
        .Global=True
        .MultiLine =True
        .IgnoreCase =True
        .Pattern= """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "str"
        .Pattern= "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num"
        .Pattern= "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num"
        .Pattern= "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "cst"
        .Pattern= "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
        Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
        If Not (.test(strContent) And objTokens.Exists(strContent)) Then
            varJson =Null
            strState = "Error"
        Else
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    EndWithEnd Sub

Sub Tokenize(objTokens, objRegEx, strContent, lngTokenId, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object

    strRes = ""
    lngCopyIndex =1With objRegEx
        ForEach objMatch In .Execute(strContent)
            strKey = "<" & lngTokenId & strType & ">"
            bMatched =TrueWith objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex +1) & strKey
                lngCopyIndex = .FirstIndex + .Length +1EndWith
            lngTokenId = lngTokenId +1
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex +1)
    EndWithEnd Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object

    strType =Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global=TrueSelectCase strType
            Case "obj"
                .Pattern= "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                ForEach objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern= "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)

                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) ThenSet varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern= "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                ForEach objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) ThenSet objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                    varTransfer = objArrayElts.Items
                Next
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) -2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global=False
                .Pattern= "\\u[0-9a-fA-F]{4}"
                Do While .test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" &Right(.Execute(varTransfer)(0).Value, 4)) *1))
                Loop
            Case "num"
                varTransfer = Evaluate(strContent)
            Case "cst"
                SelectCase LCase(strContent)
                    Case "true"
                        varTransfer =TrueCase "false"
                        varTransfer =FalseCase "null"
                        varTransfer =NullEndSelectEndSelectEndWithEnd Sub

The output is:

For actual table on the page:

Hope this helps.