javascript - 使用 VBA 按下网页上的按钮，无需打开 IE

Question

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

我可以使用此子命令打开 Internet Explorer:

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

但我想避免打开 Internet Explorer，所以我想要这样的东西:

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

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

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

我尝试了@omegastripes在评论中建议的方法，并根据他的回答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

URLEncode() 函数来自这篇文章 URLEncode 。 (我尝试使用 JScriptControl 但它不起作用，可能是因为我有 Office 64 位)。

这段代码运行没有错误，但是当我查看 htmlPage 的内容时，它几乎是空的。我认为问题是我发送的请求是错误的，但我无法纠正它，你能帮助我吗？

Answer 1

考虑下面的例子:

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

输出为:

对于页面上的实际表格:

希望这有帮助。