用VBA自动化IE时URLDownloadtofile的替代方法

Question

我已经将InternetExplorer.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