mail mail

Внимание: в связи с обновлением сайта, временно перестали отображаться исходные коды макросов в разделе «Макросы VBA Excel»
(не отображаются только длинные макросы, а небольшие по размеру макросы выводятся как и раньше)
Проблема с отображением кодов макросов будет решена в ближайшем будущем

ВНИМАНИЕ: Данная программа использует вызов системных функций - WinAPI
Поскольку синтаксис вызова этих функций в различных версиях Windows и Office может отличаться, работа программы на всех компьютерах не гарантируется!
Все размещённые на сайте макросы тестировались в Excel 2003 - 2010 под управлением 32-битной версии Windows XP

Если вы работаете в 64-битной версии Windows, или используете Office 2010 или 2013 (в котором встроена 7-я версия VBA),
то есть вероятность, что макрос работать не будет (потребуется доработка вызова функций WinAPI)
По указанным причинам, макрос не будет работать под управлением MacOS Excel 2004, 2008, 2011 и т.п.)

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

Вид исходный таблицы со ссылками на картинки в интернете

Данный макрос перебирает все строки на листе, и для каждой строки скачивает из интернета картинки, ссылки на которые присутствуют в этой строке (начиная с 3 столбца)

В процессе загрузки изображений из интернета отображается 2-уровневый прогресс-бар, на котором можно видеть текущее состояние процесса.

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

Кроме того, надстройка для вставки изображений в 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

Смотрите также аналогичный (более простой) макрос загрузки изображений

ВложениеРазмерЗагрузкиПоследняя загрузка
DownloadPictures.xls85 КБ587 часов 33 минуты назад

Комментарии

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

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

Спасибо огромнейшее за макрос!!!! Не подскажете как оставить оригинальные имена файлов?

Папки всегда разные) т.е. вместо фото_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" в двух строках?
Заранее спасибо!

Блин пацаны ВЫ СУПЕР!!!! Как я мучался и незнал как скачать кучу картинок. Офигеть как вы меня выручили. Спасибо Вам большое!!!!

Сергей,замените

Ссылка = cell.EntireRow.Cells(i).Text

на
Ссылка = cell.EntireRow.Cells(i).hyperlinks(1).address

Добрый день.
Подскажите пожалуйста, как получить ссылку, если она не написанная в ячейке, а стоит на нее.

Ребята, спасибо Вам большое! низкий поклон! макрос очень выручил!

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

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
      _   _____   __   ____    ____    _     
| | |__ / / _| | _ \ | _ \ | |__
_ | | / / | |_ | | | | | | | | | '_ \
| |_| | / /_ | _| | |_| | | |_| | | | | |
\___/ /____| |_| |____/ |____/ |_| |_|
Введите код, изображенный в стиле ASCII-арт.

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

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