在Windows 10中，Excel VBA回答Internet Explorer 11下载提示？

Question

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

如何使用“保存”来自动回答下载提示？
在进入下载部分之前，VBA代码需要单击带有以下Web html代码的按钮：

<div class="button showHistory floatRight">Visa historik</div>

我正在使用此VBA代码：

Set anchorElement = Document.getElementsByClassName("button showHistory floatRight").Item(Index:=1)
anchorElement.Click

当我单步执行代码时，此方法有效，但是在运行代码时，在anchorElement.Click行上收到错误消息：

未指定对象变量或带块变量。

对1或2有任何建议吗？

Answer 1

考虑通过XMLHttpRequest而不是IE自动化下载历史数据共享。 在下面的示例中，指定了共享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

更新

请注意，上述方法在某些情况下会使系统容易受到攻击，因为它允许通过ActiveX直接访问恶意JS代码的驱动器（和其他内容）。 假设您正在解析Web服务器响应JSON，例如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\\\Test.txt')})()}" 。 经过评估，您将找到新创建的文件C:\\Test.txt 。 因此，使用ScriptControl ActiveX进行JSON解析不是一个好主意。 检查针对基于RegEx的JSON解析器的答案的更新。

在Windows 10中，Excel VBA回答Internet Explorer 11下载提示？

问题描述

1 个解决方案

解决方案1
2 已采纳 2015-09-06 23:37:10

在Windows 10中，Excel VBA回答Internet Explorer 11下载提示？

问题描述

1 个解决方案

解决方案1 2 已采纳 2015-09-06 23:37:10

解决方案1
2 已采纳 2015-09-06 23:37:10