Скачать файлы по списку ссылок excel

    Const НазваниеПапкиДляФайлов$ = "Фотографии"    ' так будет называться создаваемая папка
    Const НомерСтолбцаСГиперссылками = 6    ' из этого столбца макрос берет гиперссылки для загрузки файлов
    Const НомерСтолбцаСИменамиФайлов = 4    ' из этого столбца макрос берет имена для создаваемых файлов
    Const НомерПервойСтрокиСДанными = 2    ' с какой строки листа начинаем обрабатывать данные
    Const РасширениеФайлов$ = ".jpg"    ' этот текст добавляется справа к именам создаваемых файлов

Sub СкачатьИзображения()
    Const НазваниеПапкиДляФайлов$ = "Фотографии"    ' так будет называться создаваемая папка
    Const НомерСтолбцаСГиперссылками = 6    ' из этого столбца макрос берет гиперссылки для загрузки файлов
    Const НомерСтолбцаСИменамиФайлов = 4    ' из этого столбца макрос берет имена для создаваемых файлов
    Const НомерПервойСтрокиСДанными = 2    ' с какой строки листа начинаем обрабатывать данные
    Const РасширениеФайлов$ = ".jpg"    ' этот текст добавляется справа к именам создаваемых файлов

    Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False
    ПапкаДляФайлов$ = ThisWorkbook.Path & "" & НазваниеПапкиДляФайлов$ & ""
    On Error Resume Next: MkDir ПапкаДляФайлов$    ' создаём папку, если её ещё нет

    Dim pi As New ProgressIndicator
    pi.Show "Загрузка файлов из интернета"
    Set sh = ActiveSheet    ' обрабатываем только активный лист

    ' диапазон заполненных ячеек в столбце НомерСтолбцаСГиперссылками (без строк заголовка таблицы)
    Set ra = sh.Range(sh.Cells(НомерПервойСтрокиСДанными, НомерСтолбцаСГиперссылками), _
                      sh.Cells(sh.Rows.Count, НомерСтолбцаСГиперссылками).End(xlUp))
    pi.StartNewAction , , "Загрузка файлов", , , ra.Cells.Count
 
    For Each cell In ra.Cells    ' перебираем все ячейки диапазона
        ' формируем путь к новому файлу, заменяя запрещённые символы в имени файла на _подчеркивание_
        ИмяФайла$ = ПапкаДляФайлов$ & Replace_symbols(cell.EntireRow.Cells(НомерСтолбцаСИменамиФайлов))
        If Not ИмяФайла$ Like "*" & РасширениеФайлов$ Then ИмяФайла$ = ИмяФайла$ & РасширениеФайлов$
 
        ' обрабатываем ссылку, преобразуя её в URLEncode
        Ссылка$ = RussianStringToURLEncode(cell.Text)
 
        pi.SubAction , "Строка: " & cell.Row, "Файл: " & ИмяФайла$
        ' сохраняем очередную ссылку в виде файла в  папку
        If DownLoadFile(Ссылка, ИмяФайла) Then
            FilesCount% = FilesCount% + 1    ' Debug.Print "Скачан файл: " & Ссылка
        Else
            MsgBox "Не удалось загрузить файл " & Ссылка, vbCritical
        End If
    Next cell
    pi.Hide    ' закрываем прогресс-бар
    Application.ScreenUpdating = True
    msg = "Обработано ссылок: " & ra.Cells.Count & ".  Загружено файлов: " & FilesCount% & vbNewLine
    msg = msg & "Файлы помещены в папку """ & ПапкаДляФайлов$ & """"
    MsgBox msg, vbInformation, "Загрузка файлов завершена"
End Sub

• 
  Вопрос задан

  более трёх лет назад
  

• 2745 просмотров

Пригласить эксперта

• 
  Показать ещё
  Загружается…
  

'---------------------------------------------------------------------------------------
' 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)