Excel VBA回答Internet Explorer 11下载提示，在Windows 10中？ [英] Excel VBA to answer Internet Explorer 11 download prompt, in Windows 10?

问题描述

我正在尝试使用Excel从 http://www.nasdaqomxnordic.com 自动下载.csv文件2010 VBA和Internet Explorer。

1. 如何使用保存自动回复下载提示？



2. 在我下载部分之前，VBA代码需要点击这个网页HTML代码的按钮：

< pre class =lang-html prettyprint-override> < div class =button showHistory floatRight> Visa historik< / div>


我正在使用这个VBA代码：

 设置anchorElement = Document.getElementsByClassName（button showHistory floatRight）。Item（Index：= 1）
 anchorElement.Click 
  / pre> 
 
 
当我执行代码时，这可以工作，但是当我运行它时，我会收到一条错误消息在 anchorElement.Click  
 
 
未指定对象变量或With-block变量。
 
 
任何有关1或2的建议？
解决方案
 XMLHttpRequest而不是IE自动化。在下面的示例中，共享ISIN被指定（用于AAK的SE0001493776），第一个请求返回共享ID（SSE36273），第二个请求通过id检索历史数据，然后在记事本中显示为文本，并保存为csv文件。
  Sub Test（）
 Dim dToDate，dFromDate，aDataBinary，sShareISIN，sShareId 
 dToDate = Date'当天
 dFromDate = DateAdd（yyyy，-1，dToDate）一年前
 sShareISIN =SE0001493776'为AAK 
 sShareId = GetId（sShareISIN）'SSE36273 
 aDataBinary = GetHistoryData （sShareId，dFromDate，dToDate）
 ShowInNotepad BytesToText（aDataBinary，us-ascii）
 SaveBytesToFile aDataBinary，C：\Test\HistoricData& sShareId& .csv
 End Sub 
 
函数GetId（sName）
 Dim oJson 
使用CreateObject（MSXML2.XMLHTTP）
。打开GET ，http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx?SubSystem=Prices&Action=Search&InstrumentISIN=& EncodeUriComponent（sName）& & json = 1，False 
 .Send 
设置oJson = GetJsonDict（.ResponseText）
结束
 GetId = oJson（inst）（@ id ）
 CreateObjectx86，True'关闭mshta主机窗口
结束函数
 
函数EncodeUriComponent（strText）
静态objHtmlfile作为对象
如果objHtmlfile是
设置objHtmlfile = CreateObject（htmlfile）
 objHtmlfile.parentWindow.execScript函数encode（s）{return encodeURIComponent（s）}，jscript
 End If 
 EncodeUriComponent = objHtmlfile.parentWindow.encode（strText）
结束函数
 
函数GetJsonDict（JsonString）
使用CreateObjectx86（ScriptControl）'通过x86 mshta主机创建ActiveX，对于64位办公兼容性
 .Language =JScript
 .ExecuteStatement函数gettype（sample）{return {} .toString.call（sample）.slice（8，-1）}
 .ExecuteStatement函数evaljson（json，er）{t ry {var sample = eval（'（'+ json +'）'）; var type = gettype（sample）; if（type！='Array'&& type！='Object'）{return er;} else {return getdict（sample）;}} catch（e）{return er;}}
。 ExecuteStatement函数getdict（sample）{var type = gettype（sample）; if（type！='Array'&& type！='Object'）返回样本; 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在样本中）{dict.add（key，getdict（sample [key]））;}} return dict;}
设置GetJsonDict = .Run（evaljson，JsonString，Nothing）
结束With 
结束函数
 
函数CreateObjectx86（可选sProgID，可选bClos​​e = False）
 
静态oWnd As Object 
 Dim bRunning As Boolean 
 
 #If Win64然后
 bRunning = InStr（TypeName（oWnd），HTMLWindow）> 0 
如果bClos​​e Then 
如果bRunning Then oWnd.Close 
退出函数
 End If 
如果不是bRunning然后
设置oWnd = CreateWindow（）
 oWnd.execScript函数CreateObjectx86（sProgID）：设置CreateObjectx86 = CreateObject（sProgID）：结束函数， VBScript
 End If 
设置CreateObjectx86 = oWnd.CreateObjectx86（sProgID）
 #Else 
如果不是bClos​​e然后设置CreateObjectx86 = CreateObject（sProgID）
 #End如果
 
结束函数
 
函数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）。运行％systemroot％\syswow64\mshta.exe关于：< head>脚本> 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 
为
为每个oShellWnd在CreateObject（Shell.Application）Windows 
设置CreateWindow = oShellWnd.GetProperty（sSignature）
如果Err.Number = 0然后退出函数
 Err.Clear 
下一个
循环
 
结束函数
 
函数GetHistoryData（sId，dFromDate，dToDate）
 Dim oParams，sPayload，sParam 
设置oParams = CreateObject（Scripting.Dictionary）
 oParams（ （Action）=GetDataSeries
 oParams（AppendIntraDay）=否
 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（e 
 oParams（ext_xslt_options）=,,
 oParams（ext_contenttype）=application / ms-excel
 oParams（ext_xslt_hiddenattrs） =，iv，ip，
 sPayload =xmlquery =< post> 
对于每个sParam在oParams 
 sPayload = sPayload& < param name =& sParam& value =& oParams（sParam）&  /> 中
下一个
 sPayload = sPayload& < /后> 中
使用CreateObject（MSXML2.XMLHTTP）
。打开POST，http://www.nasdaqomxnordic.com/webproxy/DataFeedProxy.aspx，False 
 .SetRequestHeader内容-Type，application / x-www-form-urlencoded; charset = UTF-8
 .Send sPayload 
 GetHistoryData = .ResponseBody 
 End with 
 End Function 
 
函数LZ（sValue，nDigits）
 LZ = Right（String（nDigits，0）& CStr（sValue），nDigits）
结束函数
 
函数ConvDate（d）
 ConvDate = Year（d）&  - & LZ（月（d），2）&  - & LZ（Day（d），2）
结束函数
 
函数BytesToText（aBytes，sCharSet）
使用CreateObject（ADODB.Stream）
 .Type = 1'adTypeBinary 
 .Open 
。写aBytes 
 .Position = 0 
 .Type = 2'adTypeText 
 .Charset = sCharSet 
 BytesToText = .ReadText 
 .Close 
结束
结束函数
 
 Sub SaveBytesToFile（aBytes，sPath）
使用CreateObject（ADODB.Stream）
 .Type = 1'adTypeBinary 
 .Open 
。写aBytes 
 .SaveToFile sPath，2'adSaveCreateOverWrite 
 .Close 
结束
 End Sub 
 
 Sub ShowInNotepad（sContent）
 Dim sTmpPath 
使用CreateObject（Scripting.FileSystemObject）
 sTmpPath = CreateObject（WScript.Shell）。ExpandEnvironmentStrings（％TEMP ％）& \& .GetTempName 
带.CreateTextFile（sTmpPath，True，True）
 .WriteLine（sContent）
 .Close 
结束
 CreateObject（WScript.Shell）。运行notepad.exe& sTmpPath，1，True 
 .DeleteFile（sTmpPath）
结束
 End Sub 
  
 更新 
 
 
 
请注意，上述方法在某些情况下使系统易受攻击，因为它允许直接访问驱动器（和其他东西）通过ActiveX的恶意JS代码。让我们假设您正在解析Web服务器响应JSON，如 JsonString ={a：（function（）{（new ActiveXObject（'Scripting.FileSystemObject'））。CreateTextFile（'C：\\Test .TXT'）}）（）}。评估后，您会发现新创建的文件 C：\Test.txt 。所以JSON解析与 ScriptControl  ActiveX不是一个好主意。检查基于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:\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. 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回答Internet Explorer 11下载提示，在Windows 10中？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！