Excel VBA 在 Windows 10 中回答 Internet Explorer 11 下载提示? [英] Excel VBA to answer Internet Explorer 11 download prompt, in Windows 10?
本文介绍了Excel VBA 在 Windows 10 中回答 Internet Explorer 11 下载提示?的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在尝试使用 Excel 从 http://www.nasdaqomxnordic.com 自动下载 .csv 文件2010 VBA 和 Internet Explorer.
如何使用保存"自动回答下载提示?
在我进入下载部分之前，VBA 代码需要点击带有此网页 html 代码的按钮:
我正在使用这个 VBA 代码:
Set anchorElement = Document.getElementsByClassName("button showHistory floatRight").Item(Index:=1)锚元素点击这在我单步执行代码时有效，但是当我运行它时，我在 anchorElement.Click 行上收到一条错误消息:
未指定对象变量或带块变量.
对 1 或 2 有什么建议吗?
解决方案
考虑通过 XMLHttpRequest 而不是 IE 自动化下载共享的历史数据.在下面的示例中指定了共享 ISIN(AAK 为 SE0001493776)，第一个请求返回共享 ID(SSE36273)，第二个请求通过 id 检索历史数据，然后将其作为文本显示在记事本中，并保存为 csv 文件.
子测试()Dim dToDate、dFromDate、aDataBinary、sShareISIN、sShareIddToDate = Date '当前日期dFromDate = DateAdd("yyyy", -1, dToDate) ' 一年前sShareISIN = "SE0001493776" ' 为 AAKsShareId = GetId(sShareISIN) ' SSE36273aDataBinary = GetHistoryData(sShareId, dFromDate, dToDate)ShowInNotepad BytesToText(aDataBinary, "us-ascii")SaveBytesToFile aDataBinary, "C:TestHistoricData" &sShareId &.csv"结束子函数 GetId(sName)迪奥森使用 CreateObject("MSXML2.XMLHTTP").打开GET"，http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx?SubSystem=Prices&Action=Search&InstrumentISIN="&EncodeUriComponent(sName) &"&json=1", 假.发送设置 oJson = GetJsonDict(.ResponseText)结束于GetId = oJson("inst")("@id")CreateObjectx86 , True ' 最后关闭 mshta 宿主窗口结束函数函数 EncodeUriComponent(strText)静态 objHtmlfile 作为对象如果 objHtmlfile 什么都没有，那么Set objHtmlfile = CreateObject("htmlfile")objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"万一EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)结束函数函数 GetJsonDict(JsonString)使用 CreateObjectx86("ScriptControl") ' 通过 x86 mshta 主机创建 ActiveX，以实现 64 位办公兼容性.Language = "JScript".ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}".ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type!= 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}".ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"Set GetJsonDict = .Run("evaljson", JsonString, Nothing)结束于结束函数函数 CreateObjectx86(可选 sProgID，可选 bClose = False)静态对象作为对象Dim bRunning As Boolean#如果 Win64 那么bRunning = InStr(TypeName(oWnd), "HTMLWindow") >0如果 bClose 那么如果 bRunning Then oWnd.Close退出函数万一如果没有 bRunning Then设置 oWnd = CreateWindow()oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"万一设置 CreateObjectx86 = oWnd.CreateObjectx86(sProgID)#别的如果不是 bClose 然后设置 CreateObjectx86 = CreateObject(sProgID)#万一结束函数函数创建窗口()' 来源 http://forum.script-coding.com/viewtopic.php?pid=75356#p75356Dim 签名、oShellWnd、oProc出错时继续下一步sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)CreateObject("WScript.Shell").Run "%systemroot%syswow64mshta.exe ""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no/<object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1><;/object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False做对于 CreateObject("Shell.Application").Windows 中的每个 oShellWnd设置 CreateWindow = oShellWnd.GetProperty(sSignature)如果 Err.Number = 0 然后退出函数错误清除下一个环形结束函数函数 GetHistoryData(sId, dFromDate, dToDate)Dim oParams、sPayload、sParamSet oParams = CreateObject("Scripting.Dictionary")oParams("Exchange") = "NMF"oParams("子系统") = "历史"oParams("Action") = "GetDataSeries"oParams("AppendIntraDay") = "no"oParams("仪器") = sIdoParams("FromDate") = ConvDate(dFromDate)oParams("ToDate") = ConvDate(dToDate)oParams("hi__a") = "0,5,6,3,1,2,4,21,8,10,12,9,11"oParams("ext_xslt") = "/nordicV3/hi_csv.xsl"oParams("OmitNoTrade") = "true"oParams("ext_xslt_lang") = "en"oParams("ext_xslt_options") = ",,"oParams("ext_contenttype") = "application/ms-excel"oParams("ext_xslt_hiddenattrs") = ",iv,ip,"sPayload = "xmlquery="对于 oParams 中的每个 sParamsPayload = sPayload &"<param name=""" &参数&""" 值=""" &oParams(sParam) &"""/>"下一个sPayload = sPayload &</post>"使用 CreateObject("MSXML2.XMLHTTP").打开POST"，http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx"，假.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8".发送sPayloadGetHistoryData = .ResponseBody结束于结束函数函数 LZ(sValue, nDigits)LZ = Right(String(nDigits, "0") & CStr(sValue), nDigits)结束函数函数转换日期(d)ConvDate = 年(d) &"-" &LZ(月(d), 2) &"-" &LZ(天(d), 2)结束函数函数 BytesToText(aBytes, sCharSet)使用 CreateObject("ADODB.Stream").Type = 1 ' adTypeBinary.打开.写字节.位置 = 0.Type = 2 ' adTypeText.Charset = sCharSetBytesToText = .ReadText.关闭结束于结束函数子 SaveBytesToFile(aBytes, sPath)使用 CreateObject("ADODB.Stream").Type = 1 ' adTypeBinary.打开.写字节.SaveToFile sPath, 2 ' adSaveCreateOverWrite.关闭结束于结束子子 ShowInNotepad(sContent)Dim sTmpPath使用 CreateObject("Scripting.FileSystemObject")sTmpPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") &" &.GetTempName使用 .CreateTextFile(sTmpPath, True, True).WriteLine (sContent).关闭结束于CreateObject("WScript.Shell").运行"notepad.exe" &sTmpPath, 1, 真.DeleteFile (sTmpPath)结束于结束子 更新
请注意，上述方法在某些情况下会使系统容易受到攻击，因为它允许恶意 JS 代码通过 ActiveX 直接访问驱动器(和其他内容).假设您正在解析 Web 服务器响应 JSON，例如 JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\Test.txt')})()}".评估后，您将找到新创建的文件 C:Test.txt.所以用 ScriptControl ActiveX 解析 JSON 不是一个好主意.检查基于 RegEx 的 JSON 解析器的我的答案更新.
I am trying to automate downloading of .csv files from http://www.nasdaqomxnordic.com using Excel 2010 VBA and Internet Explorer.
How to automate answering the download prompt with Save?
Before I get to the download part the VBA code needs to click on a button with this web html code:
<div class="button showHistory floatRight">Visa historik</div>
I am using this VBA code:
Set anchorElement = Document.getElementsByClassName("button showHistory floatRight").Item(Index:=1)
anchorElement.Click
This works when I step through the code but when I run it I get an error message on the line anchorElement.Click:
Object variable or With-block variable is not specified.
Any suggestions on 1 or 2?
解决方案
Consider downloading historic data for shares via XMLHttpRequest instead of IE automation. In the example below share ISIN is specified (SE0001493776 for AAK), first request returns share id (SSE36273), and second request retrieves historic data by id, then shows it in notepad as text, and saves as csv file.
Sub Test()
Dim dToDate, dFromDate, aDataBinary, sShareISIN, sShareId
dToDate = Date ' current day
dFromDate = DateAdd("yyyy", -1, dToDate) ' one year ago
sShareISIN = "SE0001493776" ' for AAK
sShareId = GetId(sShareISIN) ' SSE36273
aDataBinary = GetHistoryData(sShareId, dFromDate, dToDate)
ShowInNotepad BytesToText(aDataBinary, "us-ascii")
SaveBytesToFile aDataBinary, "C:TestHistoricData" & sShareId & ".csv"
End Sub
Function GetId(sName)
Dim oJson
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx?SubSystem=Prices&Action=Search&InstrumentISIN=" & EncodeUriComponent(sName) & "&json=1", False
.Send
Set oJson = GetJsonDict(.ResponseText)
End With
GetId = oJson("inst")("@id")
CreateObjectx86 , True ' close mshta host window at the end
End Function
Function EncodeUriComponent(strText)
Static objHtmlfile As Object
If objHtmlfile Is Nothing Then
Set objHtmlfile = CreateObject("htmlfile")
objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
End If
EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function
Function GetJsonDict(JsonString)
With CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host, for 64-bit office compatibility
.Language = "JScript"
.ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}"
.ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
.ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"
Set GetJsonDict = .Run("evaljson", JsonString, Nothing)
End With
End Function
Function CreateObjectx86(Optional sProgID, Optional bClose = False)
Static oWnd As Object
Dim bRunning As Boolean
#If Win64 Then
bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
If bClose Then
If bRunning Then oWnd.Close
Exit Function
End If
If Not bRunning Then
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
End If
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
If Not bClose Then Set CreateObjectx86 = CreateObject(sProgID)
#End If
End Function
Function CreateWindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
Dim sSignature, oShellWnd, oProc
On Error Resume Next
sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
CreateObject("WScript.Shell").Run "%systemroot%syswow64mshta.exe ""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
Function GetHistoryData(sId, dFromDate, dToDate)
Dim oParams, sPayload, sParam
Set oParams = CreateObject("Scripting.Dictionary")
oParams("Exchange") = "NMF"
oParams("SubSystem") = "History"
oParams("Action") = "GetDataSeries"
oParams("AppendIntraDay") = "no"
oParams("Instrument") = sId
oParams("FromDate") = ConvDate(dFromDate)
oParams("ToDate") = ConvDate(dToDate)
oParams("hi__a") = "0,5,6,3,1,2,4,21,8,10,12,9,11"
oParams("ext_xslt") = "/nordicV3/hi_csv.xsl"
oParams("OmitNoTrade") = "true"
oParams("ext_xslt_lang") = "en"
oParams("ext_xslt_options") = ",,"
oParams("ext_contenttype") = "application/ms-excel"
oParams("ext_xslt_hiddenattrs") = ",iv,ip,"
sPayload = "xmlquery=<post>"
For Each sParam In oParams
sPayload = sPayload & "<param name=""" & sParam & """ value=""" & oParams(sParam) & """/>"
Next
sPayload = sPayload & "</post>"
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx", False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.Send sPayload
GetHistoryData = .ResponseBody
End With
End Function
Function LZ(sValue, nDigits)
LZ = Right(String(nDigits, "0") & CStr(sValue), nDigits)
End Function
Function ConvDate(d)
ConvDate = Year(d) & "-" & LZ(Month(d), 2) & "-" & LZ(Day(d), 2)
End Function
Function BytesToText(aBytes, sCharSet)
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aBytes
.Position = 0
.Type = 2 ' adTypeText
.Charset = sCharSet
BytesToText = .ReadText
.Close
End With
End Function
Sub SaveBytesToFile(aBytes, sPath)
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aBytes
.SaveToFile sPath, 2 ' adSaveCreateOverWrite
.Close
End With
End Sub
Sub ShowInNotepad(sContent)
Dim sTmpPath
With CreateObject("Scripting.FileSystemObject")
sTmpPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") & "" & .GetTempName
With .CreateTextFile(sTmpPath, True, True)
.WriteLine (sContent)
.Close
End With
CreateObject("WScript.Shell").Run "notepad.exe " & sTmpPath, 1, True
.DeleteFile (sTmpPath)
End With
End Sub
UPDATE
Note that the above approach makes the system vulnerable in some cases, since it allows the direct access to the drives (and other stuff) for the malicious JS code via ActiveX's. Let's suppose you are parsing web server response JSON, like JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\Test.txt')})()}". After evaluating it you'll find new created file C:Test.txt. So JSON parsing with ScriptControl ActiveX is not a good idea. Check the update of my answer for the RegEx-based JSON parser.
这篇关于Excel VBA 在 Windows 10 中回答 Internet Explorer 11 下载提示?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
