关于文件：在Windows 10中，Excel VBA回答Internet Explorer 11下载提示？


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

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

  • 如何使用"保存"自动回答下载提示？

  • 在进入下载部分之前，VBA代码需要单击带有以下Web html代码的按钮：

    • 1
    Visa historik

    我正在使用此VBA代码：

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

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

    Object variable or With-block variable is not specified.

    对1或2有任何建议吗？

    相关讨论

    考虑通过XMLHttpRequest而不是IE自动化下载历史数据以共享。 在下面的示例中，指定了共享ISIN(对于AAK为SE0001493776)，第一个请求返回共享ID(SSE36273)，第二个请求按ID检索历史数据，然后将其以文本形式显示在记事本中，并另存为csv文件。

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    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>moveTo(-32000,-32000);document.title='x86Host'<hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object>shell.putproperty('" & sSignature &"',document.parentWindow);</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解析器的答案的更新。

    相关讨论