Скачивание файла в VBA и его сохранение

Мне нужно скачать файл, полученный в результате поиска REST. URL-адрес выглядит следующим образом:

https://abc.def/geh/servlet/rest/vault?oid=xxx&expr=files.file1

(Мне нужно было отредактировать его из соображений конфиденциальности ..)

Файл должен быть результатом вычислений Nastran, его может просмотреть простой Texteditor. Расширение - .pch, оно относительно велико (~ 21 МБ).

Как это можно реализовать в VBA?


rest excel vba pch
person FelixTheMan    schedule 31.03.2015    source источник
comment
Добро пожаловать в Stackoverflow. Поделитесь своими усилиями.   -  person Nagama Inamdar    schedule 31.03.2015
comment
Задумывались ли вы о поиске на этом сайте: stackoverflow.com/search?q=[vbaestive+download+file   -  person Jean-François Corbett    schedule 31.03.2015

Ответы (2)


arrow_upward
15
arrow_downward

Прежде всего - ссылка не работает. Во-вторых: в зависимости от вывода HTTP-запроса может быть 2 подхода.

Если выводится в виде файла, вы можете использовать приведенный ниже код:

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
person AnalystCave.com    schedule 31.03.2015
comment
Прежде всего - ссылка не работает Правда? Но abc.def - мой любимый сайт! - person Jean-François Corbett; 31.03.2015
comment
Мой тоже! Вместе с xyz.declare: D - person AnalystCave.com; 31.03.2015
comment
Это сработало! Из-за правил компании я не мог указать реальный URL. Код для загрузки работает отлично, однако мне нужно было добавить еще один http-запрос для входа в систему: Set WinHttpReq = CreateObject (Microsoft.XMLHTTP) WinHttpReq.Open GET, UrlLogin, False WinHttpReq.send - person FelixTheMan; 01.04.2015
comment
Прохладный! Рад, что это сработало. При необходимости я подробно остановился на этой теме в своем сообщении: analystcave.com/excel -downloading-files-using-vba - person AnalystCave.com; 10.04.2015

arrow_upward
1
arrow_downward

Если файл уже существует на сервере и его не нужно создавать с помощью запроса и т. Д., Вы можете использовать вызов 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
person SierraOscar    schedule 31.03.2015