如何抑制cookie请求 [英] How to suppress cookie request
问题描述
我在Excel 2013中使用vba来删除雅虎选项合同中的数据,而在获取数据的同时,我也收到多个请求接受cookie(见下面的对话框)。
I am using vba inside of Excel 2013 to scrape data off of Yahoo Option Contract and while I do get the data, I also get multiple requests to accept a cookie (see dialog below).
我尝试接受这一点,看看它是否会阻止更多的弹出窗口,但没有这样的运气。如何禁止对话框?
I tried accepting this to see if it would prevent further popups but no such luck. How can I suppress the dialog?
除此之外,我很确定有一个api的yahoo_option_contract可以提供一些免费的xml,但我不能让它上班任何人都可以验证是否有效,并提供一个解释如何使用它的链接?
As an aside, I'm pretty sure there is an api for yahoo_option_contract that would serve up some cookie free xml but I couldn't get it to work. Can anyone verify that is does work and provide a link that explains how to use it?
干杯
< img src =https://i.stack.imgur.com/AQLAQ.jpgalt =enter image description here>
更多信息
以下是示例链接到雅虎的网站。同样的,我发现我的代码大部分都是在以前的SO帖子
Here is a sample link to yahoo's site. It also happens that I show most of my code and scrape strategy at the bottom of a previous SO post
更新
Set http = New MSXML2.XMLHTTP60
With http
.Open "GET", aUrl, False
.send
Do Until .readyState = 4
DoEvents
Loop
End With
Select Case http.Status
Case Is = 200
Set GetHttp = http
Case Else
err.Raise Number:=ERR_WEB_CONNECTION, _
Description:="Bad Response " & http.Status & mStrings.Bracket(http.statusText)
End Select
推荐答案
尝试以下VBA代码通过XHR检索页面的HTML内容,并使用RegEx解析并输出到工作表:
Try VBA code below to retrieve HTML content of the page via XHR, parse it with RegEx and output to worksheet:
Option Explicit
Sub Scrape_Yahoo_Option_Contract()
Dim sUrl As String
Dim aHeaders
Dim sResp As String
Dim sContent
Dim oTables As Object
Dim oRows As Object
Dim aData()
Dim i As Long
' Get data
sUrl = "https://finance.yahoo.com/quote/AAPL"
aHeaders = Array( _
Array("user-agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/57.0.2987.133 Safari/537.36") _
)
XmlHttpRequest "GET", sUrl, aHeaders, "", "", sResp
' Parse tables
ParseToDict "(<table class=""[^""]*?W\(100%\)[^>]*>)([\s\S]*?)</table>", sResp, oTables
' Parse rows
For Each sContent In oTables.Items
ParseToDict "<tr><td>(.*?)</td><td>(.*?)</td></tr>", HtmlSimplify(sContent), oRows
Next
' Populate 2d array
ReDim aData(1 To oRows.Count, 1 To 2)
i = 1
For Each sContent In oRows
aData(i, 1) = GetInnerText(sContent)
aData(i, 2) = GetInnerText(oRows(sContent))
i = i + 1
Next
' Output array to worksheet 1
With ThisWorkbook.Sheets(1)
.Cells.Delete
Output2DArray .Cells(1, 1), aData
.Cells.EntireColumn.AutoFit
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "@"
.Value = aCells
End With
End With
End Sub
Sub XmlHttpRequest(sMethod As String, sUrl As String, arrSetHeaders, sFormData, sRespHeaders As String, sContent As String)
Dim arrHeader
'With CreateObject("Msxml2.ServerXMLHTTP.3.0")
' .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
With CreateObject("Msxml2.XMLHTTP")
.Open sMethod, sUrl, False
If IsArray(arrSetHeaders) Then
For Each arrHeader In arrSetHeaders
.SetRequestHeader arrHeader(0), arrHeader(1)
Next
End If
.Send sFormData
sRespHeaders = .GetAllResponseHeaders
sContent = .ResponseText
End With
End Sub
Function HtmlSimplify(ByVal sCont)
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "(<[\w\/^<]*)[\s\S]*?>"
sCont = .Replace(sCont, "$1>")
.Pattern = "(?:<span>|</span>)"
sCont = .Replace(sCont, "")
.Pattern = "(?:<small>|</small>)"
sCont = .Replace(sCont, "")
.Pattern = " "
sCont = .Replace(sCont, " ")
.Pattern = "[\f\n\r\t\v]"
sCont = .Replace(sCont, "")
.Pattern = " +"
sCont = .Replace(sCont, " ")
.Pattern = "> <"
sCont = .Replace(sCont, "><")
End With
HtmlSimplify = sCont
End Function
Sub ParseToDict(sPattern As String, sResponse As String, oDict As Object)
Dim oMatch
If oDict Is Nothing Then Set oDict = CreateObject("Scripting.Dictionary")
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = sPattern
For Each oMatch In .Execute(sResponse)
If Trim(oMatch.SubMatches(0)) <> "" Then oDict(oMatch.SubMatches(0)) = oMatch.SubMatches(1)
Next
End With
End Sub
Function GetInnerText(ByVal sHtml As String) As String
Static oHtmlfile As Object
If oHtmlfile Is Nothing Then ' init
Set oHtmlfile = CreateObject("htmlfile")
oHtmlfile.Open
oHtmlfile.Write "<body></body>"
End If
' Convert
On Error Resume Next
oHtmlfile.body.innerHTML = sHtml
GetInnerText = oHtmlfile.body.innerText
End Function
这篇关于如何抑制cookie请求的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!