Macro Download from site/Макрос для скачивания с сайта

[sanych_09]

Добрый день,

Не подскажете, как модернизировать код для скачивания файлов с вебсайта. формат файлов *.csv
я так понимаю, так как у меня есть 17 файлов,которые нужно скачать, myURL присвоить переменную, чтобы тоже циклом перебрать все 17 ссылок на сайт

это код работает, но нужно сохранить оригинальное имя файла. путь для сохранения указать там же, где будет эта книга, так как у меня есть другой чудо макрос,который в дальнейшем начнет обрабатывать скачанные файлы.


Sub DownloadFile()

Dim myURL As String

myURL = "http://site.com/report/downloadable/download/324"
`myURL = "http://site.com/report/downloadable/download/356"
`myURL = "http://site.com/report/downloadable/download/371"


Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile "C:\file.csv", 2 ' 1 = no overwrite, 2 = overwrite *** хотелось бы выбрать куда сохранить
oStream.Close
End If

End Sub

[IgorGO]

в модуле располагаете функцию:

Function SaveAsFlName() As String
  With Application.FileDialog(msoFileDialogSaveAs)
    .FilterIndex = 15
    .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "XXX"
    If .Show = -1 Then
      SaveAsFlName = .SelectedItems(1)
    End If
  End With
End Function

oStream.SaveToFile SaveAsFlName, 2

[sanych_09]

Сообщение от IgorGO

в модуле располагаете функцию:

Function SaveAsFlName() As String
  With Application.FileDialog(msoFileDialogSaveAs)
    .FilterIndex = 15
    .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "XXX"
    If .Show = -1 Then
      SaveAsFlName = .SelectedItems(1)
    End If
  End With
End Function

oStream.SaveToFile SaveAsFlName, 2

а где прописать 17 ссылок для скачивания?

Sub DownloadFile()

Dim myURL As String

myURL = "http://site.com/tracker/projectone/report/downloadable/download/325"


Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile SaveAsFlName, 2 ' 1 = no overwrite, 2 = overwrite *** 
oStream.Close
End If

End Sub

Function SaveAsFlName() As String
  With Application.FileDialog(msoFileDialogSaveAs)
    .FilterIndex = 15
    .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "XXX"
    If .Show = -1 Then
      SaveAsFlName = .SelectedItems(1)
    End If
  End With
End Function

[IgorGO]

Sub DownloadFile()

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Dim myURL(17) As String, i as Long

myURL(1) = "http://site.com/tracker/projectone/report/downloadable/download/325"
myURL(2) = "http://site.com/tracker/projectone/report/downloadable/download/326"
...
myURL(17) = "http://site.com/tracker/projectone/report/downloadable/download/325"

for i = 1 to 17
WinHttpReq.Open "GET", myURL(i), False, "username", "password"
....
oStream.SaveToFile SaveAsFlName(myURL(i)), 2 
...
next
...
End sub


Function SaveAsFlName(Url as string) As String
  With Application.FileDialog(msoFileDialogSaveAs)
    .FilterIndex = 15
    .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & URL

[sanych_09]

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

Sub DownloadFile()

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Dim myURL(2) As String, i As Long

myURL(1) = "http://ut-tracker.com/tracker/projectone/report/downloadable/download/386"
myURL(2) = "http://ut-tracker.com/tracker/projectone/report/downloadable/download/296"

For i = 1 To 2

WinHttpReq.Open "GET", myURL(i), False, "username", "password"
WinHttpReq.send

myURL(i) = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile SaveAsFlName(myURL(i)), 2 ' 1 = no overwrite, 2 = overwrite *** ???????? ?? ??????? ???? ?????????
oStream.Close
End If
Next

End Sub

Function SaveAsFlName(Url As String) As String
  With Application.FileDialog(msoFileDialogSaveAs)
    .FilterIndex = 15
    .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & myURL
    If .Show = -1 Then
      SaveAsFlName = .InitialFileName
    End If
  End With
End Function

[IgorGO]

я догадиваюсь, что происходит в коде, который написал
я не всегда догадываюсь, что нужно пользователю

пониманиете, фраза

хотелось бы выбрать куда сохранить

предполагает дать возможность выбрать имя (а если нужно и место хранения на усмотрение пользователя)
а если есть 17 заведомо известных УРЛ и 17 соотв. им имен файлов...
переменную с именами файлом можете взять с предыдущей задачи
а вместо этого

SaveAsFlName(myURL(i))

используйте просто

CuDir & FlNm(i)

(те же конструкции, что и в прошлом файле)

[sanych_09]

спасибо, буду пробовать что-то написать)))

[sanych_09]

Ура!!!! Получилось. Файлы скачиваются. имя им присваивается согласно того, как я их прописал.

а как сделать, чтобы скачивать с оригинальным названием файла?

Sub DownloadFile()

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Dim myURL(2) As String, FlNm(2) As String, i As Long, CuDir As String

CuDir = ActiveWorkbook.Path & "\"


myURL(1) = "http://site.com/tracker/projectone/report/downloadable/download/325"
FlNm(1) = "PH1_New_Colocation_DPR_NEW_.csv"
myURL(2) = "http://site.com/tracker/projectone/report/downloadable/download/296"
FlNm(2) = "PH1_FTK_DPR_NEW_.csv"

For i = 1 To 2

WinHttpReq.Open "GET", myURL(i), False, "username", "password"
WinHttpReq.send


myURL(i) = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile CuDir & FlNm(i)
oStream.Close
End If
Next

End Sub

[EducatedFool]

а как сделать, чтобы скачивать с оригинальным названием файла?

после строки If WinHttpReq.Status = 200 Then
напишите строку

MsgBox WinHttpReq.GetAllResponseHeaders

может, в сообщении увидите нужное имя файла (оттуда несложно его извлечь)

поскольку протестировать ваш код возможности нет, - нет и готового решения
потому что сервер может выдавать файл по-разному (через один или несколько редиректов)

[sanych_09]

Хотел бы еще раз выразить огромную благодарность всем кто откликнулся IgorGO, EducatedFool!!!!

Я далек от VBA, но делать рутинную работу тоже глупо каждый раз. хочу оптимизировать + как ни странно, мне начинает нравится использования VBA. почти первый этап пройден: скачивание с сайта, копирование информации с скаченных файлов в один. третий этапом будет обработать нужную информацию и отобразить ее в сводной табличке заданного формата (пока все сделал через формулу ДВВСЫЛ (Indirect) )


за совет спасибо. сообщение выдало filename="точное имя файла_дата.csv"

как теперь изменить код, чтобы файлы сами сохранялись как они есть?