Данный макрос перебирает все строки на листе, и для каждой строки скачивает из интернета картинки, ссылки на которые присутствуют в этой строке (начиная с 3 столбца)
В процессе загрузки изображений из интернета отображается 2-уровневый прогресс-бар, на котором можно видеть текущее состояние процесса.
Если вам требуется вставлять много изображений на лист Excel, - то вам поможет надстройка, позволяющая производить поиск изображений в заданной папке, и производить вставку картинок в ячейки или примечания
Кроме того, надстройка для вставки изображений в Excel умеет загружать картинки из интернета (по ссылкам в таблице Excel)
При формировании имён файлов и путей к папкам применяется замена запрещённых символов на допустимые:
http://excelvba.ru/code/Replace_symbols
Для загрузки изображений применена WinAPI-функция URLDownloadToFile в таком виде:
Function DownLoadFile(FromPathName, ToPathName) As Boolean DownLoadFile = URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0 End Function
Папки с подпапками создаются тоже с использованием WinAPI: http://excelvba.ru/code/MkDir
Для обработки данных на листе использован такой макрос:
Sub ОсновнойМакрос() Dim sh As Worksheet, cell As Range, ra As Range: Application.ScreenUpdating = False Dim pi As New ProgressIndicator pi.Show "Загрузка фотографий" Set sh = ActiveSheet ' обрабатываем только активный лист ' For Each sh In ThisWorkbook.Worksheets ' перебираем все листы ' диапазон заполненных ячеек в столбце А, начиная с A2 Set ra = sh.Range(sh.[A2], sh.Range("A" & sh.Rows.Count).End(xlUp)) For Each cell In ra.Cells ' перебираем все ячейки диапазона ' формируем путь к новому файлу Путь = ThisWorkbook.Path & "\" & Replace_symbols(sh.Name) & _ "\" & Replace_symbols(cell) & "\" n = 100 / ra.Cells.Count: s1 = d * n + 1: s2 = (d + 1) * n: d = d + 1 pi.StartNewAction s1, s2, "Каталог: " & cell, "Загрузка фото с листа " & sh.Name CreateFolderWithSubfolders Путь ' создаём папку КолвоСсылок = cell.EntireRow.Cells(sh.Columns.Count).End(xlToLeft).Column - 2 If КолвоСсылок < 0 Then КолвоСсылок = 0 Dim pi2 As New ProgressIndicator: Set pi2 = pi.AddChildIndicator("Загрузка фото из строки") pi2.StartNewAction 5, 100, "Загрузка фото ...", , , КолвоСсылок ' перебираем все ссылки For i = 3 To cell.EntireRow.Cells(sh.Columns.Count).End(xlToLeft).Column pi2.SubAction , Путь, Replace_symbols(cell.Next) & "_" & (i - 2) & ".jpg" ИмяФайла = Путь & Replace_symbols(cell.Next) & "_" & (i - 2) & ".jpg" Ссылка = cell.EntireRow.Cells(i).Text ' Debug.Print ИмяФайла, Ссылка ' сохраняем очередную ссылку в виде файла в нужную папку If DownLoadFile(Ссылка, ИмяФайла) Then Debug.Print "Скачан файл: " & Ссылка Else MsgBox "Не удалось загрузить файл " & Ссылка, vbCritical End If Next i pi2.Hide Next cell ' Next sh ' перебираем все листы (переход к следующему листу) pi.Hide ' закрываем прогресс-бар End Sub
Смотрите также аналогичный (более простой) макрос загрузки изображений
Комментарии
ошибку выдаёт
Спасибо! Работает отлично! Важно правильно названия написать, не читает со знаками различными
Спасибо огромное! Как сделать что бы не останавливался при отсутствии файла, а переходил к следующей ссылке?
Доброго дня. Имеется прайс поставщика со ссылками на изображения на сайте и имеется накладная с закупкой от них, но уже без ссылок, как скачать только те изображения наименование которых содержится в нашей накладной
Спасибо большое за парсер. Подскажите пожалуйста, как сделать так что бы он не переименовывал картинки а просто сохранял так как есть на сайте?
Ниже в комментах есть ответ на ваш вопрос
Не работает под версией exel 10 64 bit версией как исправить не меняя систему
Здравствуйте. Кто подскажет как сделать.
Например имя картинки А-201 папка А-201. Если несколько картинок то картинки помещались бы в разные папки с названиями А-201_1, А-201_2, А-201_3 , а имя картинки оставалось А-201.
Очень нужная вещь! Большое человеческое спасибо!
Этот макрос не будет работать на 64-битной системе (он разрабатывался под 32-битный Office)
Используйте новую версию макроса, он работает на всех компьютерах.
Здравствуйте. Отличный макрос. Но стало выдавать ошибку. http://i-fotki.info/19/fdf367b53a5f26e820969bab65a3a00005ce5d228433797.j...
Помогите пожалуйста
Используйте более универсальный макрос
http://excelvba.ru/programmes/PastePictures
там есть поддержка кириллицы в ссылках, и намного больше опций
Очень крутой макрос!
Но ест вопрос, как сделать так, чтобы скачивались картинки у которых в ссылке присутствуют кириллические символы? А то выводится сообщение, что не удается скачать картинку.
Спасибо огромнейшее за макрос!!!! Не подскажете как оставить оригинальные имена файлов?
Папки всегда разные) т.е. вместо фото_1.jpg, фото_2.jpg, фото_3.jpg будет ссылка на ячейку с именем файла.
К примеру вместо
pi2.SubAction , Путь, Replace_symbols(cell.Next) & "_" & (i - 2) & ".jpg"
ИмяФайла = Путь & Replace_symbols(cell.Next) & "_" & (i - 2) & ".jpg"
будет (без учета перевода в макрос)
pi2.SubAction , Путь, CONCATENATE("J"; (i - 2))
ИмяФайла = Путь & CONCATENATE("J"; (i - 2))
где в ячейках J1 природа.jpg
J2 документ.doc
J3 фото.gif
К сожалению совсем не знаю язык, поэтому написал как в экселе))
Спасибо!
Григорий, я не совсем понял, как сохранить несколько файлов (ссылок ведь несколько в каждом столбце) под одним именем (из первой строки)...
Можем написать макрос под заказ, - обращайтесь.
Спасибо Огромное!!
Подскажите, как сохранить все файлы по ссылкам во всем столбце используя для этого имя в первой строке?
Например: Природа.jpg (под ним столбец с ссылками) , описание.doc (под ним столбец с ссылками) Спасибо)
оч круто! спасибо!
Спасибо, все отлично!
Доброй ночи.
Игорь, замените в коде ".jpg"
на
mid(cell.EntireRow.Cells(i).Text, instrrev(cell.EntireRow.Cells(i).Text, "."))да, расширение присутствует в ссылке, то есть последние 4-5 символов, типа .png или .jpeg
Игорь, а как узнать оригинальное расширение файла?
Если оно присутствует в ссылке на картинку, - то можно
(а если нет - то никак)
Отличный макрос, очень помог. Спасибо!
Есть вопрос, прошу по-возможности подсказать: Если мне необходимо сохранить оригинальное расширение скаченного файла, но с таким же принципом формирования имени:
pi2.SubAction , Путь, Replace_symbols(cell.Next) & "_" & (i - 2) & ".jpg"
ИмяФайла = Путь & Replace_symbols(cell.Next) & "_" & (i - 2) &
Что мне необходимо подставить вместо ".jpg" в двух строках?
Заранее спасибо!
Блин пацаны ВЫ СУПЕР!!!! Как я мучался и незнал как скачать кучу картинок. Офигеть как вы меня выручили. Спасибо Вам большое!!!!
Сергей,замените
на
Добрый день.
Подскажите пожалуйста, как получить ссылку, если она не написанная в ячейке, а стоит на нее.
Ребята, спасибо Вам большое! низкий поклон! макрос очень выручил!
Отправить комментарий