Загрузка изображений из интернета по ссылкам в одну папку

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

Исходные данные для работы макроса:

таблица, в которой содержатся по меньшей мере 2 столбца - один с гиперссылками, второй - с именами файлов.

Особенности макроса:

создаваемым файлам присваиваются имена из выбранного столбца листа Excel
макрос корректно работает со ссылками, содержащими символы кириллицы
автоматическое добавление расширения для скачиваемых файлов (если имя файла из ячейки его не содержит)

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

Кроме того, надстройка для вставки изображений в Excel умеет загружать картинки из интернета (по ссылкам в таблице Excel)

Бесплатно скачать надстройку вставки картинок в 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

Вложения:

DownloadPictures2.xls

91.5 КБ

76224 просмотра

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Игорь (администратор сайта), 31 Май 2015 - 10:26.#1

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

Антон, 31 Май 2015 - 02:13.#2

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

И обнаружил проблему, если у ссылки на картинку в конце пробел, то картинка скачаться не может. Можно как-то автоматически это исправить, чтобы макрос в случае обнаружения пробела после ссылки его не удалял?

Спасибо огромное!

Владимир, 17 Май 2015 - 23:13.#3

Всё отлично! Разобрался!) Спасибки. Теперь остается допилить обработку в 1С для загрузки этих изображений.(Скачал 25 тыс. изображений за 3 мин.)

Игорь (администратор сайта), 17 Май 2015 - 22:59.#4

Владимир, обычно на одном сайте все картинки одного типа (JPG или PNG)
Потому, достаточно указать фиксированное расширение для скачиваемых картинок.
Ну или можно брать расширение файла из ссылки (если оно там есть)
Автоматически же определять тип скачанного файла (анализируя его структуру) - можно, но сложно (у меня нет макроса для этого)

Владимир, 17 Май 2015 - 22:04.#5

Доброго времени суток!
Подскажите плиз, файл эксель: столбцы: артикул, наименование и ссылка на изображение в интернете. Макросом скачивает все изображения, НО после скачивания нет Типа файла. Мне важно что бы скачанный файл имел Имя и Тип, который имеется у файла в интернете. Можно ли такое изобразить?
Спасибо.

Игорь (администратор сайта), 30 Апр 2015 - 17:44.#6

Так, может, у вас ссылки ведут не на картинки, а на страницы товаров с текстом и картинками?
Попробуйте воспользоваться этой программой, она более универсальная:
http://excelvba.ru/programmes/PastePictures

Lenar, 30 Апр 2015 - 17:39.#7

Не грузит файлы. подскажите как исправить? может у кого были тоже проблемы?

Игорь (администратор сайта), 9 Фев 2015 - 14:44.#8

Роман, вот вам функция для извлечения имени файла из ссылки:

Function GetFilenameFromURL(ByVal txt) As String
    On Error Resume Next
    GetFilenameFromURL = Replace_symbols(Split(txt, "/")(UBound(Split(txt, "/"))))
End Function
 
Function Replace_symbols(ByVal txt As String) As String
    st$ = "/\:?*|""<>"        ' а эти символы - разрешены: ~!@#$%^=`
    For i% = 1 To Len(st$)
        txt = Replace(txt, Mid(st$, i, 1), "_")
    Next
    Replace_symbols = txt
End Function

Как её применить в имеющемся макросе, - надеюсь, сами разберётесь.

роман, 9 Фев 2015 - 14:27.#9

Друзья, подскажите, а как сделать чтобы имя файла оставалось таким же как и в ссылке?

Гость, 2 Фев 2015 - 11:51.#10

спасибо)))

Игорь (администратор сайта), 2 Фев 2015 - 02:01.#11

обратите внимание на строку кода

 Const НомерСтолбцаСИменамиФайлов = 4    ' из этого столбца макрос берет имена для создаваемых файлов

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

Гость, 2 Фев 2015 - 01:28.#12

есть список ссылок с фотографиями. при скачивании скачивается только 1 фото. Почему не скачиваются все одновременно и как это исправить?

Дмитрий, 23 Апр 2014 - 15:17.#13

СПАСИБО!!!
очень помогли!

Роман, 20 Апр 2014 - 11:49.#14

Спасибо)))

Игорь (администратор сайта), 20 Апр 2014 - 01:55.#15

Здравствуйте, Роман.
замените код

If DownLoadFile(Ссылка, ИмяФайла) Then
    FilesCount% = FilesCount% + 1    ' Debug.Print "Скачан файл: " & Ссылка
Else
    MsgBox "Не удалось загрузить файл " & Ссылка, vbCritical
End If

на

If DownLoadFile(Ссылка, ИмяФайла) Then
    FilesCount% = FilesCount% + 1
    cell.next = "успешно"
Else
    cell.next = "ошибка"
End If

Роман, 20 Апр 2014 - 00:16.#16

Добрый День!

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

Гость, 30 Мар 2014 - 19:26.#17

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

Игорь (администратор сайта), 2 Мар 2014 - 14:21.#18

Рузана, а как вы представляете себе упорядоченные картинки в папке?
Есть же возможность сохранить картинки под именами из заданного столбца, - в отдельном столбце проставьте числа типа 1,2,3 и т.д. (протянув их на нужное количество строк), и используйте этот столбец как имена файлов.
Единственный способ упорядочивания файлов в папке, - это сортировка по именам / дате создания / размеру файла,
так что других вариантов нет.
Возможно, подойдет и просто сортировка по дате создания, - картинки ведь создавались подряд, одна за другой.
Если между моментами создания файлов проходила хотя бы секунда, - есть шанс упорядочить картинки без дополнительных действий.

Рузана, 2 Мар 2014 - 00:25.#19

Здравствуйте!

Я сохранила картинки с ссылок с файла excel, но они находятся в беспорядочном состоянии в папке, как их упорядочить, согласно тому,как они были расположены в excel?

Владимир, 30 Янв 2014 - 18:35.#20

В названии файла есть нули "0001243" при сохранении имя файла становится "1243", как в названии добавить недостающие нули?

Игорь (администратор сайта), 21 Ноя 2013 - 16:05.#21

Антонина, надо было заменит в коде строку

Ссылка$ = RussianStringToURLEncode(cell.Text)

на

Ссылка$ = RussianStringToURLEncode(cell.Hyperlinks(1).Address)

чтобы брался не ТЕКСТ из ячейки, а ГИПЕРССЫЛКА из неё

Выслал файл с исправлениями на почту

Антонина, 21 Ноя 2013 - 14:15.#22

Отправила файл на почту

Антонина, 21 Ноя 2013 - 14:11.#23

прошу прощения, не в имя файла, а имя гиперссылки :(

Игорь (администратор сайта), 21 Ноя 2013 - 14:09.#24

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

Антонина, 21 Ноя 2013 - 14:00.#25

Доброго времени суток! Скажите а как пользоваться макросом, если имя гиперссылки >>, хотя ссылка верная. Пишет невозможно загрузить файл. Пробовала вставлять в имя файла гиперссылку, тогда работает. У меня огромный массив, помогиииииииите! :)

Дмитрий, 3 Ноя 2013 - 22:35.#26

Спасибо! Буду разбираться!

Игорь (администратор сайта), 30 Окт 2013 - 03:30.#27

Здравствуйте, Дмитрий.

Как-то так это делается:

    Dim sha As Shape
    For Each sha In ActiveSheet.Shapes        ' перебираем все картинки на листе
        If Not sha.Hyperlink Is Nothing Then        ' если картинке назначена гиперссылка
            Link$ = sha.Hyperlink.Address        ' получаем адрес ссылки

            ИмяФайла = "c:\test"
            If DownLoadFile(Link$, ИмяФайла) Then        ' пробуем скачать файл
                Debug.Print "Скачан файл: " & Link$
            Else
                MsgBox "Не удалось загрузить файл " & Link$, vbCritical
            End If
        End If
    Next

Дмитрий, 30 Окт 2013 - 00:46.#28

Добрый день!
Проблема в том, что в ячейках находятся картинки, и в картинках уже прописаны гиперссылки на картинки в интернете.
Как можно выдернуть гиперссылки из картинок? как загружать картинки из интернета в таком случае?
никак не могу разобраться..

Заранее спасибо!

Василий, 12 Июн 2013 - 15:12.#29

Быстрота и полнота ответа - вне конкуренции!

Игорь (администратор сайта), 12 Июн 2013 - 13:37.#30

Здравствуйте, Василий.

Замените строку

 MsgBox "Не удалось загрузить файл " & Ссылка, vbCritical

на что-то вроде этого:

DownLoadFile "http...тут нужная ссылка на NoPhoto.jpg", ИмяФайла ' скачиваем из интернета

или на

FileCopy "Полный путь к файлу NoPhoto.jpg на вашем компе", ИмяФайла ' копируем файл

Василий, 12 Июн 2013 - 13:19.#31

Как изменить макрос, чтобы для тех ссылок, по которым нет изображений, сохранялось изображение по одной фиксированной ссылке (из интернет или на локальном компьютере)?
*Изображение "NoPhoto".

MaldeR, 15 Авг 2012 - 15:41.#32

заменил строку
Ссылка$ = RussianStringToURLEncode(cell.Text)
на
Ссылка$ = RussianStringToURLEncode(cell.Hyperlinks(1).Address)
и скачивает не зависимо от отображения ссылки в ячейке

п.с. Спасибо огромное за макрос и ответ!!!:)

MaldeR, 15 Авг 2012 - 14:00.#33

заменил cell.Value = cell.Value на cell.Value = addr$ и заработало

MaldeR, 15 Авг 2012 - 13:29.#34

как я понял ячейка должна выглядеть так "http://адрес сайта/photo/001.jpg", но
в офис 2010 функция FormulaHyperlink заменяет =ГИПЕРССЫЛКА("http://адрес сайта/photo/001.jpg";"фото") на "фото" и картинка не скачивается

Игорь (администратор сайта), 15 Авг 2012 - 03:42.#35

MaldeR, в случае гиперссылок, выполненных при помощи формул, надо либо сначала их преобразовать в обычные гиперссылки,
либо при помощи функции FormulaHyperlink получить адрес ссылки из ячейки с формулой, перед выполнением загрузки файла:

Function FormulaHyperlink(ByRef cell As Range) As String
    If cell.HasFormula And (cell.Hyperlinks.Count = 0) Then
        If cell.Formula Like "=HYPERLINK*" Then
            FormulaHyperlink = Evaluate(Mid$(Split(cell.Formula, ",")(0), 12))
        End If
    End If
End Function

Необходимая функция и макрос замены гиперссылок есть в этой статье: http://excelvba.ru/code/FormulaHyperlinks

MaldeR, 14 Авг 2012 - 19:51.#36

что делать, если ссылка в таком виде?
=ГИПЕРССЫЛКА("http://адрес сайта/photo/001.jpg";"фото")

Денис, 16 Янв 2012 - 21:34.#37

Разобрался сам, удалил следующее
Else
MsgBox "Не удалось загрузить файл " & Ссылка, vbCritical

и все стало работать как мне надо. Еще раз большое спасибо !!!!!

Денис, 16 Янв 2012 - 21:24.#38

Столкнулся с единственной проблеммой - если строчка пустая то выводится сообщение "Не удалось загрузить файл", а так как таких строк у меня очень много (не ко всем товарам имеется изображение) давольно таки не удобно постоянно сообщение закрывать.... есть ли вариант убрать это сообщение из кода?????
Заранее благодарствую.

Денис, 16 Янв 2012 - 20:51.#39

Отличный макрос!!!! Автору БОЛЬШОЕ СПАСИБО!!!!!!!

Игорь (администратор сайта), 10 Апр 2011 - 10:56.#40

За обрабатываемый диапазон ячеек отвечает эта строка в коде:

Set ra = sh.Range(sh.Cells(НомерПервойСтрокиСДанными, НомерСтолбцаСГиперссылками), _
                      sh.Cells(sh.Rows.Count, НомерСтолбцаСГиперссылками).End(xlUp))

Если надо обработать строки заданного диапазон, можете заменить эту строку следующим кодом:
(выберите наиболее подходящий вариант из трёх предложенных)

    ' будут обработаны гиперссылки в строках с 8-й по 25-ю включительно
    Set ra = sh.Range(sh.Cells(8, НомерСтолбцаСГиперссылками), sh.Cells(25, НомерСтолбцаСГиперссылками))

    ' будут обработаны гиперссылки в диапазоне ячеек d4:d32
    Set ra = sh.Range("d4:d32")

    ' будут обработаны гиперссылки в столбце НомерСтолбцаСГиперссылками ТОЛЬКО ДЛЯ ВЫДЕЛЕННЫХ СТРОК
    ' (достаточно, чтобы в строке была выделена хоть одна ячейка)
    Set ra = Range(Selection.EntireRow, Columns(НомерСтолбцаСГиперссылками))

Интересующийся, 10 Апр 2011 - 07:00.#41

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

Отправить комментарий

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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

Загрузка изображений из интернета по ссылкам в одну папку

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL