考虑通过 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
UPDATE
请注意，上述方法在某些情况下会使系统容易受到攻击，因为它允许恶意 JS 代码通过 ActiveX 直接访问驱动器（和其他内容）。假设您正在解析 Web 服务器响应 JSON，例如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"。评估后你会发现新创建的文件C:\Test.txt。所以 JSON 解析为ScriptControlActiveX 不是一个好主意。检查更新我的答案 https://stackoverflow.com/a/30494373/2165759用于基于 RegEx 的 JSON 解析器。
