在VBA中下载文件并存储它

我需要从RESTsearch中下载一个文件。 该URL如下所示:

HTTPS://abc.def/geh/servlet/rest/vault OID = XXX&EXPR = files.file1

(由于隐私原因,我需要编辑它。)

该文件应该是Nastran计算的结果,它可以通过一个简单的Texteditor查看。 扩展名是.pch,比较大(〜21mb)

那怎么能在VBA中实现?

首先 – 链接不起作用。 其次,根据HTTP请求的输出,可以有两种方法。

如果输出是文件,你可以使用下面的代码:

Sub DownloadFile(url As String, filePath As String) Dim WinHttpReq As Object, attempts As Integer attempts = 3 On Error GoTo TryAgain TryAgain: attempts = attempts - 1 Err.Clear If attempts > 0 Then Set WinHttpReq = CreateObject("Microsoft.XMLHTTP") WinHttpReq.Open "GET", url, False WinHttpReq.send If WinHttpReq.Status = 200 Then Set oStream = CreateObject("ADODB.Stream") oStream.Open oStream.Type = 1 oStream.Write WinHttpReq.responseBody oStream.SaveToFile filePath, 2 ' 1 = no overwrite, 2 = overwrite oStream.Close End If End If End Sub 

如果输出是简单的文本HTML响应,则可以将输出保存到文件中

 Function GetXMLHTTPResult(url As String) Dim XMLHTTP As Object, attempts As Integer attempts = 3 On Error GoTo TryAgain TryAgain: attempts = attempts - 1 Err.Clear If attempts > 0 Then Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP") XMLHTTP.Open "GET", url, False XMLHTTP.setRequestHeader "Content-Type", "text/xml" XMLHTTP.setRequestHeader "Cache-Control", "no-cache" XMLHTTP.setRequestHeader "Pragma", "no-cache" XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0" XMLHTTP.send GetXMLHTTPResult = XMLHTTP.ResponseText End If End Function Sub SaveFile(url) res = GetXMLHTTPResult(url) Open "C:\res.txt" For Output As #1 Write #1, res Close #1 End Sub 

如果文件已经存在于服务器上,并且不必通过查询等方式构build,则可以使用如下所示的API调用:

 Option Explicit #If VB7 Then Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As Long #Else Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If Sub SO() Dim fileURL As String, saveLocation As String fileURL = "https://abc.def/geh/servlet/rest/vault?oid=xxx&expr=files.file1" saveLocation = "C:\Users\bloggsj\desktop\files.file1" MsgBox "Download completed: " & (URLDownloadToFile(0, fileURL, saveLocation, 0, 0) = 0) End Sub