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

by

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.

More Related Contents:

  1. Controlling IE11 “Do you want to Open/Save” dialogue window buttons in VBA
  2. Automate saveas dialogue for IE9 (vba)
  3. PHP: Force file download and IE, yet again
  4. VBA Internet Explorer Automation – How to Select “Open” When Downloading a File
  5. How can I automate Save as dialog box in IE11 using VBA?
  6. VBA WinHTTP to download file from password proteced https website
  7. In Excel VBA, what is the way to check if the web page is fully loaded?
  8. How do I get values from a hidden worksheet using VBA [closed]
  9. How to copy cells that contain certain text to another worksheet [closed]
  10. VBA Macro for copying and pasting columns on same excel sheet
  11. Excel VBA, code to count the # of filled cells, then find highest and 2nd highest and subtract the corresponding column #’s [closed]
  12. How to add default signature in Outlook
  13. Levenshtein Distance in VBA [closed]
  14. VBA Runtime Error 1004 “Application-defined or Object-defined error” when Selecting Range
  15. Assign event handlers to controls on user form created dynamically in VBA
  16. Programmatic Access To Visual Basic Project Is Not Trusted
  17. Conditional Formatting using Excel VBA code
  18. Sending HTTP requests with VBA from Word
  19. What does ReDim Preserve do?
  20. How to create a separate CSV file from VBA?
  21. VBA: How to change the value of another cell via a function?
  22. Excel (Office 365) restarts automatically while executing UDF
  23. Running VBA from a HYPERLINK()
  24. Open a workbook from VBA and disable Workbook_Open() code?
  25. How to filter listbox values based on a Textbox value
  26. Text To Clipboard in VBA Windows 10 Issue
  27. Excel VBA using FileSystemObject to list file last date modified
  28. Remove double quotation from write statement in vba
  29. User Defined Type (UDT) as parameter in public Sub in class module (VB6)
  30. How to improve the speed of VBA macro code?

Leave a Comment