Хитрости »
Основные понятия (23)
Сводные таблицы и анализ данных (9)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (14)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (63)
Разное (38)
Баги и глюки Excel (2)

Как скачать файл из интернета по ссылке

Вся суть статьи уже в заголовке. Возникает порой необходимость скачивания файлов из интернета только на основании ссылки. Например, это какие-то постоянно меняющиеся данные или автоматически генерируемая другим кодом ссылка. Или еще более усугубленный вариант - строк 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

Код необходимо скопировать и вставить в книгу в стандартный модуль. Макросы должны быть разрешены.

Основная функция, отвечающая за непосредственно скачивание - это функция API(Application Programming Interface) URLDownloadToFile. Она объявлена в самом верху кода. Там есть страшные директивы вроде #If Win64 Then. Это особые директивы, которые работают даже вне процедур. Поэтому не надо удивляться, что они вне всяких Sub и тем более не надо эти Sub-ы добавлять. При этом так же не надо удивляться, если какие-то из строк внутри этих директив будут подсвечены компилятором VBA красным шрифтом. На функциональность это не повлияет.

Вызов скачивания файла происходит обычным обращением к функции CallDownload. Например, есть ссылка для скачивания: http://www.excel-vba.ru/files/book.xls. И сохранить надо под именем "Книга1.xls". Вызываем функцию скачивания файла:

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, 1 093 скачиваний)


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Outlook Power Query и Power BI VBA работа в редакторе VBA управление кодами Бесплатные надстройки Дата и время Диаграммы и графики Записки Защита данных Интернет Картинки и объекты Листы и книги Макросы и VBA Надстройки Настройка Печать Поиск данных Политика Конфиденциальности Почта Программы Работа с приложениями Работа с файлами Разработка приложений Сводные таблицы Списки Тренинги и вебинары Финансовые Форматирование Формулы и функции Функции Excel Функции VBA Ячейки и диапазоны акции MulTEx анализ данных баги и глюки в Excel ссылки
Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти
Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2018 Excel для всех   Войти