使用VBA在网页上按下按钮，而不用打开IE [英] Press a button on a webpage using VBA and without opening IE

问题描述

我想知道是否可以在网页上单击按钮，而无需在IE中打开页面。网页是动态生成的，点击按钮会调用脚本来改变页面的内容。

我可以通过这个子菜单打开Internet Explorer：

  Sub DownloadPageScript（strUrl As String，htmlPage as htmlDocument，strScript As String）
 
 Dim IE As对象
 
设置IE = CreateObject（InternetExplorer.application）
 IE.navigate strUrl 
 
 
 DoEvents 
 Loop Until IE。 ReadyState = READYSTATE_COMPLETE 
 
'运行与按钮关联的脚本以获取数据
 IE.Document.parentWindow.execScript strScript，jscript
 
 
 DoEvents 
循环直到IE.ReadyState = READYSTATE_COMPLETE 
 
设置htmlPage = IE.Document 
 
结束Sub 
  

但是我想避免打开Internet Explorer，所以我想这样：

  Sub Download_Page（strU RL作为字符串，htmlPage作为HTMLDocument的，strScript作为字符串）
 
尺寸XMLHTTP作为对象
'
将XMLHTTP =的CreateObject（ MSXML2.XMLHTTP）
 XMLHTTP。打开GET，strUrl，False 
 xmlHttp.setRequestHeaderContent-Type，text / xml
 xmlHttp.send 
'
'这里我应该添加一些内容来执行脚本
'
'执行后
'
设置htmlPage =新htmlDocument 
 htmlPage.body.innerHTML = xmlHttp.ResponseText 
'
 End Sub 
  

我期望能找到类似于 xmlHttp.execute（args ）方法来复制单击按钮的操作，但我错了。
所以我的问题是：如果我不想打开Internet Explorer，是否可以复制按钮点击？如果是的话我该怎么办？

基于评论中的想法的新方法

我尝试了@omegastripes在评论中建议的方法，并且我写下了他的答案

对于页面上的实际表：

希望这会有所帮助。

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 that changes the content of the page.

I am able to do this opening Internet Explorer with this sub:

Sub DownloadPageScript(strUrl As String, htmlPage As htmlDocument, strScript As String)

  Dim IE            As Object

  Set IE = CreateObject("InternetExplorer.application")
  IE.navigate strUrl

  Do
      DoEvents
  Loop Until IE.ReadyState = READYSTATE_COMPLETE 

  ' Run the scripts associated to the button to get the data
  IE.Document.parentWindow.execScript strScript, "jscript"

  Do
      DoEvents
  Loop Until IE.ReadyState = READYSTATE_COMPLETE

  Set htmlPage = IE.Document

End Sub

But I would like to avoid opening Internet Explorer so I would like to something like this:

Sub Download_Page(strUrl As String, htmlPage As htmlDocument, strScript As String)

  Dim xmlHttp      As Object
  '
  Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
  xmlHttp.Open "GET", strUrl, False
  xmlHttp.setRequestHeader "Content-Type", "text/xml"
  xmlHttp.send
  '
  ' Here I should add something to execute the script
  ' 
  ' After execution
  '
  Set htmlPage = New htmlDocument
  htmlPage.body.innerHTML = xmlHttp.ResponseText
  '
End Sub

I was expecting to find something like a xmlHttp.execute(args) method to replicate the action of clicking the button but I was wrong. So my question is: Is it possible to replicate the button click if I do not want to open Internet Explorer? and if yes what should I do?

New approach based on the idea in the comments

I tried the approach suggested by @omegastripes in the comments and I wrote this sub taken by his answer 33484763:

Sub TestDownload()

  Dim xmlHttp      As Object
  Dim htmlPage       As htmlDocument
  Dim strExportURL   As String
  Dim strFormData    As Variant
  Dim strContent     As String


    ' build exportURL parameter
  strExportURL = Join(Array( _
      "p_p_id=ScommesseAntepostPalinsesto_WAR_scommesseportle", _
      "p_p_lifecycle=2", _
      "p_p_resource_id=dettagliManifestazione", _
      "p_p_cacheability=cacheLevelPage", _
      "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codDisc=1", _
      "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codMan=21", _
      "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codScomm=3", _
      "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_codClusterScomm=80", _
      "_ScommesseAntepostPalinsesto_WAR_scommesseportlet_filtro=0" _
      ), "&")

  ' build the whole form data
  strFormData = Join(Array( _
        "languageCode=en", _
        "exportURL=" & URLEncode(strExportURL) _
    ), "&")

  ' POST XHR to retrieve the content
  Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
  xmlHttp.Open "POST", "http://www.sisal.it/scommesse-matchpoint/palinsesto", False
  xmlHttp.setRequestHeader "Content-Type", "application/json"
  xmlHttp.send strFormData

  Set htmlPage = New htmlDocument
  htmlPage.body.innerHTML = xmlHttp.responseText
  '
End Sub

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String
  Dim bytes() As Byte, b As Byte, i As Integer, space As String

  If SpaceAsPlus Then space = "+" Else space = "%20"

  If Len(StringVal) > 0 Then
    With New ADODB.Stream
      .Mode = adModeReadWrite
      .Type = adTypeText
      .Charset = "UTF-8"
      .Open
      .WriteText StringVal
      .Position = 0
      .Type = adTypeBinary
      .Position = 3 ' skip BOM
      bytes = .Read
    End With

    ReDim result(UBound(bytes)) As String

    For i = UBound(bytes) To 0 Step -1
      b = bytes(i)
      Select Case b
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Chr(b)
        Case 32
          result(i) = space
        Case 0 To 15
          result(i) = "%0" & Hex(b)
        Case Else
          result(i) = "%" & Hex(b)
      End Select
    Next i

    URLEncode = Join(result, "")
  End If
End Function

The URLEncode() function is from this post URLEncode. (I tried to use JScriptControl but It does not work probably because I have Office 64-bit).

This code runs without errors but when I look to the content of htmlPage it is almost empty. I think the problem is that the request I am sending is wrong but I am not able to correct it, can you help me?

解决方案

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
    End With

    ParseJson strJsonString, varJson, strState

    arrScommessaList = varJson("scommessaList")
    For Each 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 or array to be returned as result
    ' 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
    End With
End 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 = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & lngTokenId & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
            lngTokenId = lngTokenId + 1
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End 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 = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each 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) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set 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"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

The output is:

For actual table on the page:

Hope this helps.

这篇关于使用VBA在网页上按下按钮，而不用打开IE的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！