mail mail

ВНИМАНИЕ: Данная программа использует вызов системных функций - 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 КБ191 неделя 1 день назад

Комментарии

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

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

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

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

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

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

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

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

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

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

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