Question

我一直在使用ExcelExplorer.application和Excel VBA很少有问题。我遇到的一个问题是从网站下载文件。我可以得到“打开/另存为”按钮，但这就是我被卡住的地方。

我尝试过使用URLDownloadToFile，它似乎与我所拥有的InternetExplorer.application对象没有相同的会话。它通常返回网页的HTML文本，说明需要进行身份验证。如果我打开了多个浏览器并且其中一些旧浏览器已经过身份验证，那么它会在大部分时间内下载该文件。

有没有办法使用InternetExplorer.application对象本身下载文件？如果没有，是否有某种方法可以将URLDownloadtofile函数与已经过身份验证并登录到网站的对象相关联？

编辑：

我一直在使用的代码是：

    IE2.navigate ("https://...")
    strURL = "https://..."
    strPath = "c:\..."
    Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)

我也试过了：

    Do While IE2.Readystate <> 4
        DoEvents
    Loop
    SendKeys "%S"
    IE2.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT

并且：

    Dim Report As Variant
    Report = Application.GetSaveAsFilename("c:\...", "Excel Files (*.xls), *.xls")

除了第一个有时会保存实际文件的内容之外，其中任何一个都没有成功，但有时会保存指出身份验证错误的网站。

谢谢，

戴夫

Answer 1

我设法用一些JavaScript解决了类似的问题。

第一步是让JavaScript将文件内容下载到二进制数组中（一旦用户已经过身份验证，它就不需要进行其他身份验证）。

然后，我需要将此二进制数组传递回VBA。我不知道另一种方式，所以我将这个数组的内容打印成一个临时的DIV元素（用JavaScript）作为字符串，然后用VBA读取它并将其转换回二进制数组。

最后，我使用ADODB.Stream类从给定的二进制数组重新创建了该文件。

下载单个文件所需的时间随着此文件的大小而几何增长。因此，此方法不适用于大型文件（> 3MB），因为下载单个文件需要5分钟以上。

以下是执行此操作的代码：

'Parameters:
' * ie - reference to the instance of Internet Explorer, where the user is already authenticated.
' * sourceUrl - URL to the file to be downloaded.
' * destinationPath - where the file should be saved.
'Be aware that the extension of the file given in [destinationPath] parameter must be
'consistent with the format of file being downloaded. Otherwise the function below will
'crash on the line: [.SaveToFile destinationPath, 2]
Public Function saveFile(ie As Object, sourceUrl As String, destinationPath As String)
    Dim binData() As Byte
    Dim stream As Object
    '------------------------------------------------------------------------------------

    binData = getDataAsBinaryArray(ie, sourceUrl)

    Set stream = VBA.CreateObject("ADODB.Stream")
    With stream
        .Type = 1
        .Open
        .write binData
        .SaveToFile destinationPath, 2
    End With

End Function



Private Function getDataAsBinaryArray(Window As Object, Path As String) As Byte()
    Const TEMP_DIV_ID As String = "div_binary_transfer"
    '---------------------------------------------------------------------------------------------
    Dim strArray() As String
    Dim resultDiv As Object
    Dim binAsString As String
    Dim offset As Integer
    Dim i As Long
    Dim binArray() As Byte
    '---------------------------------------------------------------------------------------------

    'Execute JavaScript code created automatically by function [createJsScript] in
    'the given Internet Explorer window.
    Call Window.Document.parentWindow.execScript(createJsScript(TEMP_DIV_ID, Path), "JavaScript")

    'Find the DIV with the given id, read its content to variable [binAsString]
    'and then convert it to array strArray - it is declared as String()
    'in order to make it possible to use function [VBA.Split].
    Set resultDiv = Window.Document.GetElementById(TEMP_DIV_ID)
    binAsString = VBA.Left(resultDiv.innerhtml, VBA.Len(resultDiv.innerhtml) - 1)
    strArray = VBA.Split(binAsString, ";")


    'Convert the strings from the [strArray] back to bytes.
    offset = LBound(strArray)
    ReDim binArray(0 To (UBound(strArray) - LBound(strArray)))
    For i = LBound(binArray) To UBound(binArray)
        binArray(i) = VBA.CByte(strArray(i + offset))
    Next i


    getDataAsBinaryArray = binArray


End Function


'Function to generate JavaScript code doing three tasks:
' - downloading the file with given URL into binary array,
' - creating temporary DIV with id equal to [divId] parameter,
' - writing the content of binary array into this DIV.
Private Function createJsScript(divId As String, url As String) As String

    createJsScript = "(function saveBinaryData(){" & vbCrLf & _
                        "//Create div for holding binary array." & vbCrLf & _
                        "var d = document.createElement('div');" & vbCrLf & _
                        "d.id = '" & divId & "';" & vbCrLf & _
                        "d.style.visibility = 'hidden';" & vbCrLf & _
                        "document.body.appendChild(d);" & vbCrLf & _
                        "var req = null;" & vbCrLf & _
                        "try { req = new XMLHttpRequest(); } catch(e) {}" & vbCrLf & _
                        "if (!req) try { req = new ActiveXObject('Msxml2.XMLHTTP'); } catch(e) {}" & vbCrLf & _
                        "if (!req) try { req = new ActiveXObject('Microsoft.XMLHTTP'); } catch(e) {}" & vbCrLf & _
                        "req.open('GET', '" & url & "', false);" & vbCrLf & _
                        "req.overrideMimeType('text/plain; charset=x-user-defined');" & vbCrLf & _
                        "req.send(null);" & vbCrLf & _
                        "var filestream = req.responseText;" & vbCrLf & _
                        "var binStream = '';" & vbCrLf & _
                        "var abyte;" & vbCrLf & _
                        "for (i = 0; i < filestream.length; i++){" & vbCrLf & _
                        "    abyte = filestream.charCodeAt(i) & 0xff;" & vbCrLf & _
                        "    binStream += (abyte + ';');" & vbCrLf & _
                        "}" & vbCrLf & _
                        "d.innerHTML = binStream;" & vbCrLf & _
                    "})();"

End Function

Answer 2

这样的事情怎么样？

Public Sub OpenWebXLS()
' *************************************************
' Define Workbook and Worksheet Variables
' *************************************************
Dim wkbMyWorkbook As Workbook
Dim wkbWebWorkbook As Workbook
Dim wksWebWorkSheet As Worksheet

Set wkbMyWorkbook = ActiveWorkbook

' *************************************************
' Open The Web Workbook
' *************************************************
Workbooks.Open ("http://www.sportsbookreviewsonline.com/scoresoddsarchives/nba/nba%20odds%202015-16.xlsx")

' *************************************************
' Set the Web Workbook and Worksheet Variables
' *************************************************
Set wkbWebWorkbook = ActiveWorkbook
Set wksWebWorkSheet = ActiveSheet

' *************************************************
' Copy The Web Worksheet To My Workbook and Rename
' *************************************************
wksWebWorkSheet.Copy After:=wkbMyWorkbook.Sheets(Sheets.Count)
wkbMyWorkbook.Sheets(ActiveSheet.Name).Name = "MyNewWebSheet"

' *************************************************
' Close the Web Workbook
' *************************************************
wkbMyWorkbook.Activate
wkbWebWorkbook.Close

End Sub

使用VBA自动化IE时，替代URLDownloadtofile

2 个答案: