Excel VBA to answer Internet Explorer 11 download prompt, in Windows 10?

后端未结

关注

 1  1939

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

相关标签:

1条回答

面向向阳花

2020-11-28 17:26

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.

0 讨论(0)