[英]Alternative to URLDownloadtofile when automating IE with VBA
I have been using InternetExplorer.application with Excel VBA for quite a while with few issues. 我已经将InternetExplorer.application与Excel VBA一起使用了相当长的一段时间,几乎没有出现任何问题。 One problem I have is downloading a file from website.
我遇到的一个问题是从网站下载文件。 I can get as far as having the "Open/Save As" buttons appear but that is where I am stuck.
我可以看到出现“打开/另存为”按钮,但那才是我所困的地方。
I've tried using URLDownloadToFile and it does not seem to work through the same session as the InternetExplorer.application objects that I have. 我尝试使用URLDownloadToFile,它似乎无法通过与我拥有的InternetExplorer.application对象相同的会话来工作。 It usually returns the HTML text for a webpage stating that authentication is required.
它通常返回网页的HTML文本,指出需要进行身份验证。 If I have multiple browsers open and some of the old ones are already authenticated then it will download the file most of the time.
如果我打开了多个浏览器,并且某些旧的浏览器已经通过身份验证,则它将在大多数时间下载文件。
Is there a way to download the file using the InternetExplorer.application object itself? 有没有一种使用InternetExplorer.application对象本身下载文件的方法? If not, is there some way I can associate the URLDownloadtofile function with the object that is already authenticated and logged into the website?
如果没有,是否可以通过某种方法将URLDownloadtofile函数与已通过身份验证并登录到网站的对象相关联?
EDIT: 编辑:
The code I've been using is: 我一直在使用的代码是:
IE2.navigate ("https://...")
strURL = "https://..."
strPath = "c:\..."
Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)
I've also tried: 我也尝试过:
Do While IE2.Readystate <> 4
DoEvents
Loop
SendKeys "%S"
IE2.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
And: 和:
Dim Report As Variant
Report = Application.GetSaveAsFilename("c:\...", "Excel Files (*.xls), *.xls")
No success in any of these, except for the first one which sometimes saves the actual file, but sometimes saves the website that states the authentication error. 除了第一个有时会保存实际文件,但有时会保存指出身份验证错误的网站的第一个例外,其他任何方法都没有成功。
Thanks, 谢谢,
Dave 戴夫
I have managed to solve similar issue with some JavaScript. 我设法用一些JavaScript解决了类似的问题。
The first step is to make JavaScript download the content of the file into a binary array (it doesn't require another authentication once the user is already authenticated). 第一步是使JavaScript将文件的内容下载到二进制数组中(一旦用户已经通过身份验证,则不需要其他身份验证)。
Then, I needed to pass this binary array back to VBA. 然后,我需要将此二进制数组传递回VBA。 I didn't know the other way, so I print the content of this array into a temporary DIV element (with JavaScript) as a string and then read it with VBA and convert it back to binary array.
我不知道另一种方式,所以我将这个数组的内容作为字符串打印到一个临时的DIV元素(使用JavaScript)中,然后使用VBA读取它并将其转换回二进制数组。
Finally, I re-created the file from the given binary array by using ADODB.Stream class. 最后,我使用ADODB.Stream类从给定的二进制数组重新创建了文件。
The time required to download a single file grows geometrically with the size of this file. 下载单个文件所需的时间与该文件的大小成几何关系。 Therefore, this method is not suitable for large files (> 3MB) , since it tooks more than 5 minutes then to download a single file.
因此, 此方法不适用于大文件(> 3MB) ,因为下载单个文件花费了5分钟以上的时间。
Below is the code to do that: 下面是执行此操作的代码:
'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
How about something like this? 这样的事情怎么样?
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.