Как скачать файл из интернета по ссылке
Вся суть статьи уже в заголовке. Возникает порой необходимость скачивания файлов из интернета только на основании ссылки. Например, это какие-то постоянно меняющиеся данные или автоматически генерируемая другим кодом ссылка. Или еще более усугубленный вариант - строк 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 KiB, 4 002 скачиваний)
Статья помогла? Поделись ссылкой с друзьями!
Видеоуроки
Поиск по меткам
Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистикаКомментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум
Добрый день. Что нужно исправить?, у меня при скачивании очень часто появляется сообщение "Невозможно скачать файл. Возможно, у Вас нет прав на создание файлов в выбранной директории. Попробуйте выбрать другую папку для сохранения. " Пробовал менять папку, диск C: и D:, но ничего не помогает. Что нужно сделать подскажите пожалуйста, очень надо.
- Нужно сохранить файл Excel в формате .xlsm с поддержкой макросов
Доброго дня Дмитрий!
Спасибо большое за Ваш код. все отлично работает.
Для того чтоб не выскакивала ошибка : "Невозможно скачать файл. Возможно, у Вас нет прав на создание файлов в выбранной директории. Попробуйте выбрать другую папку для сохранения. ", приходится в URL указывать полный путь который включает так же и название файла.
Вопрос:
В названии файла всегда указана дата обновления, к примеру "20191007_dopolnitelbnoe_soglaschenie.doc"
Как сделать чтоб скачивало независимо от даты? знак * не помогает