[英]Excel VBA to answer Internet Explorer 11 download prompt, in Windows 10?
I am trying to automate downloading of .csv files from http://www.nasdaqomxnordic.com using Excel 2010 VBA and Internet Explorer. 我正在尝试使用Excel 2010 VBA和Internet Explorer自动从http://www.nasdaqomxnordic.com下载.csv文件。
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: 在进入下载部分之前,VBA代码需要单击带有以下Web html代码的按钮:
<div class="button showHistory floatRight">Visa historik</div>
I am using this VBA code: 我正在使用此VBA代码:
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
: 当我单步执行代码时,此方法有效,但是在运行代码时,在
anchorElement.Click
行上收到错误消息:
Object variable or With-block variable is not specified.
未指定对象变量或带块变量。
Any suggestions on 1 or 2? 对1或2有任何建议吗?
Consider downloading historic data for shares via XMLHttpRequest instead of IE automation. 考虑通过XMLHttpRequest而不是IE自动化下载历史数据共享。 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.
在下面的示例中,指定了共享ISIN(对于AAK为SE0001493776),第一个请求返回共享ID(SSE36273),第二个请求按ID检索历史数据,然后将其以文本形式显示在记事本中,并另存为csv文件。
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:\Test\HistoricData" & 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%\syswow64\mshta.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. 请注意,上述方法在某些情况下会使系统容易受到攻击,因为它允许通过ActiveX直接访问恶意JS代码的驱动器(和其他内容)。 Let's suppose you are parsing web server response JSON, like
JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\\\Test.txt')})()}"
. 假设您正在解析Web服务器响应JSON,例如
JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\\\Test.txt')})()}"
。 After evaluating it you'll find new created file C:\\Test.txt
. 经过评估,您将找到新创建的文件
C:\\Test.txt
。 So JSON parsing with ScriptControl
ActiveX is not a good idea. 因此,使用
ScriptControl
ActiveX进行JSON解析不是一个好主意。 Check the update of my answer for the RegEx-based JSON parser. 检查针对基于RegEx的JSON解析器的答案的更新 。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.