Парсинг картинок через макрос Excel
Первая часть нашей задачи была в проверке URL на доступность. Почитайте, перед тем как будете применять скрипт из этой статьи: Проверка доступности URL.
Данный макрос для Excel нужен для парсинга картинок по URL. В рамках нашей задачи нужно было не только спарсить картинки, но и присвоить им имена в виде чисел. В столбце А в таблице Excel укажите ссылки (предварительно, проверьте другим скриптом доступность ссылок!), в столбце B укажите название, с этим названием картинка будет сохранена. В макросе также можно прописать путь, куда конкретно сохранять картинку. Если Вам не нужны названия, для корректности выполнения макроса все же дайте названия в столбце B от 1 до бесконечности.
Данный макрос для Excel нужен для парсинга картинок по URL. В рамках нашей задачи нужно было не только спарсить картинки, но и присвоить им имена в виде чисел. В столбце А в таблице Excel укажите ссылки (предварительно, проверьте другим скриптом доступность ссылок!), в столбце B укажите название, с этим названием картинка будет сохранена. В макросе также можно прописать путь, куда конкретно сохранять картинку. Если Вам не нужны названия, для корректности выполнения макроса все же дайте названия в столбце B от 1 до бесконечности.
Навигация по статье
Напишите свой вопрос
Отвечу оперативно на Ваши вопросы, оставьте удобный способ связи с Вами
Существуют онлайн сервисы по парсингу картинок по URL, однако все они предлагают тестовый режим (100-300 картинок), либо сохраняют картинки беспорядочно, без названий, с названием - "абракадабра". Мы подготовили макрос для Excel, который сохраняет картинки на ПК по прописанному пути, например D://Pictures с названиями, к каждому URL.
- имеем 1 лист. В столбец А загружаем список URL (по количеству URL не ограниченно, но при большом количестве макрос может выполняться довольно долго!). В столбце B напишите названия картинок, с этими названиями картинки будут сохранены. Если не хотите давать названия, то хотя бы променумеруйте строки с URL.
- заходим в Разработчик, нажимаем кнопку Visual Basic. Если у Вас в Excel нету вкладки Разработчик прочитайте статью: Как создать макрос. Либо нажмите сочетание клавиш Alt+F11.
- Нажмите ПКМ по первой строке, затем выберете Insert, затем Module. Откроется консоль для написания кода VBA. Вставьте код макроса, напишите путь для сохранения картинок в коде (я подсветил этот момент в коде ниже зеленым цветом) и запустите макрос. Все. Дальше можно кушать печеньки и пить чай, пока макрос делает работу за Вас.
Целесообразность макроса
Описание макроса
Sub DownloadImagesFromURL()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim imgURL As String
Dim fileName As String
Dim savePath As String
Dim fullPath As String
Dim http As Object
Dim stream As Object
Dim folderPath As String
' Установите путь для сохранения файлов (измените на свой)
folderPath = "D:\Pictures\"
' Проверяем, существует ли папка, если нет - создаем
If Dir(folderPath, vbDirectory) = "" Then
MkDir folderPath
End If
' Указываем текущий лист
Set ws = ThisWorkbook.ActiveSheet
' Находим последнюю строку в столбце A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Создаем объекты для HTTP-запроса
Set http = CreateObject("MSXML2.XMLHTTP")
Set stream = CreateObject("ADODB.Stream")
Application.ScreenUpdating = False
For i = 1 To lastRow
' Получаем URL и имя файла
imgURL = Trim(ws.Cells(i, 1).Value)
fileName = Trim(ws.Cells(i, 2).Value)
' Проверяем, что оба поля заполнены
If imgURL <> "" And fileName <> "" Then
' Добавляем расширение .jpg если его нет в имени файла
If InStr(fileName, ".") = 0 Then
fileName = fileName & ".jpg"
End If
fullPath = folderPath & fileName
On Error Resume Next
' Открываем HTTP-соединение
http.Open "GET", imgURL, False
http.send
If http.Status = 200 Then
' Настраиваем поток для записи
stream.Open
stream.Type = 1 ' Бинарный тип
stream.Write http.responseBody
stream.SaveToFile fullPath, 2 ' 2 = перезаписать если файл существует
stream.Close
' Отмечаем успешную загрузку
ws.Cells(i, 3).Value = "Успешно"
Debug.Print "Сохранено: " & fileName
Else
ws.Cells(i, 3).Value = "Ошибка: " & http.Status
Debug.Print "Ошибка при загрузке: " & imgURL
End If
On Error GoTo 0
Else
ws.Cells(i, 3).Value = "Пропущено (нет данных)"
End If
Next i
' Очищаем объекты
Set stream = Nothing
Set http = Nothing
Application.ScreenUpdating = True
MsgBox "Загрузка завершена! Файлы сохранены в: " & folderPath, vbInformation
End Sub
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim imgURL As String
Dim fileName As String
Dim savePath As String
Dim fullPath As String
Dim http As Object
Dim stream As Object
Dim folderPath As String
' Установите путь для сохранения файлов (измените на свой)
folderPath = "D:\Pictures\"
' Проверяем, существует ли папка, если нет - создаем
If Dir(folderPath, vbDirectory) = "" Then
MkDir folderPath
End If
' Указываем текущий лист
Set ws = ThisWorkbook.ActiveSheet
' Находим последнюю строку в столбце A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Создаем объекты для HTTP-запроса
Set http = CreateObject("MSXML2.XMLHTTP")
Set stream = CreateObject("ADODB.Stream")
Application.ScreenUpdating = False
For i = 1 To lastRow
' Получаем URL и имя файла
imgURL = Trim(ws.Cells(i, 1).Value)
fileName = Trim(ws.Cells(i, 2).Value)
' Проверяем, что оба поля заполнены
If imgURL <> "" And fileName <> "" Then
' Добавляем расширение .jpg если его нет в имени файла
If InStr(fileName, ".") = 0 Then
fileName = fileName & ".jpg"
End If
fullPath = folderPath & fileName
On Error Resume Next
' Открываем HTTP-соединение
http.Open "GET", imgURL, False
http.send
If http.Status = 200 Then
' Настраиваем поток для записи
stream.Open
stream.Type = 1 ' Бинарный тип
stream.Write http.responseBody
stream.SaveToFile fullPath, 2 ' 2 = перезаписать если файл существует
stream.Close
' Отмечаем успешную загрузку
ws.Cells(i, 3).Value = "Успешно"
Debug.Print "Сохранено: " & fileName
Else
ws.Cells(i, 3).Value = "Ошибка: " & http.Status
Debug.Print "Ошибка при загрузке: " & imgURL
End If
On Error GoTo 0
Else
ws.Cells(i, 3).Value = "Пропущено (нет данных)"
End If
Next i
' Очищаем объекты
Set stream = Nothing
Set http = Nothing
Application.ScreenUpdating = True
MsgBox "Загрузка завершена! Файлы сохранены в: " & folderPath, vbInformation
End Sub
Макрос VBA для Excel - парсинг картинок с помощью макроса Excel
Посетите мой телеграм канал!
Посетите мой канал в телеграм, в нем, Правда, много полезного! К каналу прикреплен чат, в котором можно написать свой вопрос по таблицам.
Разработка и ведение таблиц в Excel и Гугл таблицах
Самозанятый - Абдуллина Индира Ринатовна, ИНН 025700449805, дата постановки на учёт, в качестве налогоплательщика 12.11.2021
Email для документов: damir.abdullin248@gmail.com, Telegram - https://t.me/mmsenyy27
Email для документов: damir.abdullin248@gmail.com, Telegram - https://t.me/mmsenyy27
