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.
