Вся суть статьи уже в заголовке. Возникает порой необходимость скачивания файлов из интернета только на основании ссылки. Например, это какие-то постоянно меняющиеся данные или автоматически генерируемая другим кодом ссылка. Или еще более усугубленный вариант - строк 100 со ссылками на файлы, которые надо скачать...Вот уж радости руками по каждой клацать :)
Поэтому выкладываю решение, которое в большинстве случае поможет при помощи Visual Basic for Applications скачать файл на основании ссылки URL:
'--------------------------------------------------------------------------------------- ' File : mDownloadFileFromURL ' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке '--------------------------------------------------------------------------------------- Option Explicit 'объявление функции API - URLDownloadToFile ' работает на любых ПК под управлением ОС Windows ' на MAC код работать не будет #If Win64 Then 'для операционных систем с 64-разрядной архитектурой Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong #Else #If VBA7 Then 'для любых операционных систем с офисом 2010 и выше Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr #Else 'для 32-разрядных операционных систем 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 #End If 'переменная для хранения пути к папке Dim sFilePath As String Function CallDownload(sFileURL As String, sFileName As String) ' sFileURL - ссылка URL для скачивания файла ' sFileName - имя файла с расширением, которое будет присвоено после скачивания Dim h If sFilePath = "" Then 'диалоговое окно выбора папки 'подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/ With Application.FileDialog(msoFileDialogFolderPicker) If .Show = False Then Exit Function End If sFilePath = .SelectedItems(1) End With End If If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\" 'проверяем есть ли файл с таким же именем в выбранной папке If Dir(sFilePath & sFileName, 16) = "" Then 'файла нет - скачиваем h = DownloadFileAPI(sFileURL, sFilePath & sFileName) Else 'файл есть - запрос на перезапись If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then 'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно 'отменяем загрузку If IsBookOpen(sFileName) Then MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _ vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else h = DownloadFileAPI(sFileURL, sFilePath & sFileName) End If End If End If CallDownload = h End Function 'функция скачивания файла в выбранную папку Function DownloadFileAPI(sFileURL, ToPathName) ' sFileURL - ссылка URL для скачивания файла ' ToPathName - полный путь с именем файла для сохранения Dim h Dim sFilePath As String Dim sFileName As String 'вызов функции API для непосредственно скачивания h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0) 'если h = False - файл не удалось скачать, показываем инф.окно If h = False Then MsgBox "Невозможно скачать файл." & vbNewLine & _ "Возможно, у Вас нет прав на создание файлов в выбранной директории." & vbNewLine & _ "Попробуйте выбрать другую папку для сохранения", vbInformation, "www.excel-vba.ru" Exit Function Else 'файл успешно скачан sFileName = Dir(ToPathName, 16) sFilePath = Replace(ToPathName, sFileName, "") If MsgBox("Файл сохранен в папку: " & sFilePath & _ vbNewLine & "Открыть файл сейчас?", vbYesNo, "www.excel-vba.ru") = vbYes Then If IsBookOpen(sFileName) Then MsgBox "Файл с именем '" & sFileName & "' уже открыт. Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else Workbooks.Open ToPathName End If End If End If DownloadFileAPI = h End Function 'Функция проверки - открыта ли книга с заданным именем 'подробнее: ' http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/ Function IsBookOpen(wbName As String) As Boolean Dim wbBook As Workbook For Each wbBook In Workbooks If Windows(wbBook.Name).Visible Then If wbBook.Name = wbName Then IsBookOpen = True: Exit For End If Next wbBook End Function |
Код необходимо скопировать и вставить в книгу в стандартный модуль. Макросы должны быть разрешены.
Sub DownloadFile() Call CallDownload("http://www.excel-vba.ru/files/book.xls", "Книга1.xls") 'вызываем скачивание файла End Sub |
Функция сама запросит папку для сохранения файла и после скачивания предложит открыть этот файл. Если такой файл уже есть - будет предложено его перезаписать.
К статье приложен файл, в котором код чуть расширен - он позволяет скачивать файлы сразу из множества ячеек, проставляя при этом признак - скачан файл или нет. И если сразу весь список обработать не получилось и какие-то файлы не удалось скачать(например, имена совпадали, а заменять файлы не надо было), то в этом случае можно будет повторно запустить код и скачиваться будут лишь те, у которых нет статуса "
Так же, т.к. ячеек много, перед скачиванием файлов будет выбор - запрашивать ли открытие файлов после скачивания или нет. Если открывать не надо, следует ответить Нет. Тогда файлы просто будут скачаны в указанную папку. Однако, если в этой папке будут расположены файлы с идентичными именами - запрос на перезапись все же появится, при этом для каждого файла. Если подобный запрос так же мешает, то надо этот блок:
'проверяем есть ли файл с таким же именем в выбранной папке If Dir(sFilePath & sFileName, 16) = "" Then 'файла нет - скачиваем h = DownloadFileAPI(sFileURL, sFilePath & sFileName) Else 'файл есть - запрос на перезапись If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then 'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно 'отменяем загрузку If IsBookOpen(sFileName) Then MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _ vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else h = DownloadFileAPI(sFileURL, sFilePath & sFileName) End If End If End If |
заменить на всего одну строку:
h = DownloadFileAPI(sFileURL, sFilePath & sFileName) |
Следует учитывать, что при этом можно потерять какие-то важные файлы. Поэтому подобные вещи вы делаете на свой страх и риск.
Так же всегда надо помнить еще одну вещь: не все сайты вот так запросто разрешают скачивать с них файлы, тем более пачками. Особенно это актуально для всякого рода форексов, сайтов с результатами матчей, котировками и иже с ними. Возможно, получится скачать один, два, три - десять файлов. Но всегда может случиться так, что сайт просто заблокирует ваш IP до конца дня, т.к. на сайте установлено ограничение на автоматизированное обращение извне. А где-то еще и капчу могут запросить. При этом для разных сайтов решение данной проблемы может быть различным и не всегда решаемым
Tips_Macro_DownloadFileFromURL.xls (64,0 КиБ, 4 485 скачиваний)
Добрый день. Что нужно исправить?, у меня при скачивании очень часто появляется сообщение "Невозможно скачать файл. Возможно, у Вас нет прав на создание файлов в выбранной директории. Попробуйте выбрать другую папку для сохранения. " Пробовал менять папку, диск C: и D:, но ничего не помогает. Что нужно сделать подскажите пожалуйста, очень надо.
- Нужно сохранить файл Excel в формате .xlsm с поддержкой макросов
Доброго дня Дмитрий!
Спасибо большое за Ваш код. все отлично работает.
Для того чтоб не выскакивала ошибка : "Невозможно скачать файл. Возможно, у Вас нет прав на создание файлов в выбранной директории. Попробуйте выбрать другую папку для сохранения. ", приходится в URL указывать полный путь который включает так же и название файла.
Вопрос:
В названии файла всегда указана дата обновления, к примеру "20191007_dopolnitelbnoe_soglaschenie.doc"
Как сделать чтоб скачивало независимо от даты? знак * не помогает