Как скачать фото через эксель по ссылкам

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

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

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

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

• создаваемым файлам присваиваются имена из выбранного столбца листа 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

• 76266 просмотров

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

Доброго дня!
Есть таблица с ссылками на картинки (www.сайт. /картинка.jpg)
Как массово загрузить картинки по этим ссылкам?
Есть ли бесплатный способ?
Спасибо!

• Вопрос задан более трёх лет назад
• 396 просмотров

Комментировать
Решения вопроса 1

Артём @monkeybone Автор вопроса
начинающий web разработчик
Всем спасибо!
Нашел макрос для Excel который это делает, немного подработал его для себя
МАКРОС
Ответ написан более трёх лет назад
Комментировать
Нравится Комментировать
Ответы на вопрос 1
Сергей Ильин @sunsexsurf
IT & creative

почему бы не воспользоваться бесплатным проходом по циклу?
что-то в духе:

from PIL import Image image_list = [тут у вас список ссылок с картинками] for i in image_list: image = Image.open(i) image.save(имя картинки.png)

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

image_number = 1 image_name = 'file number <>.png'.format(image_number)

и потом image_number увеличивать на 1 к каждому новому i in image_list

Как скачать все фото по ссылкам с csv?

Как можно массово скачать все изображения в одну папку? может есть какая функция или макрос?

• Вопрос задан более трёх лет назад
• 1122 просмотра

3 комментария

Простой 3 комментария

Мне кажется, это проще без екселя решить
WebforSelf @WebforSelf Автор вопроса
Василий Банников, ссылок на изображение просто около 1500.

WebforSelf, ну да. Скрипт на питоне в три строчки
Решения вопроса 0
Ответы на вопрос 2

Григорий Боев @ProgrammerForever Куратор тега Excel
Учитель, автоэлектрик, программист, музыкант

Можно так, например. Для небольших объёмов — самое то. Список файлов в list.txt
Код сохранить как bat или cmd

mkdir downloads wget -x -i list.txt --secure-protocol=auto -nc -c -P downloads>log.txt

Ответ написан более трёх лет назад
Нравится 1 3 комментария
WebforSelf @WebforSelf Автор вопроса
а куда сохранятся картинки? это получается винда сделает?

Григорий Боев @ProgrammerForever Куратор тега Excel
WebforSelf, в папку downloads, которую сам же скрипт и сделает

винда сделает?

Надо установить wget для windows

Григорий Боев, в win10 есть curl

Krasnoarmeec @Krasnoarmeec

На Экселе получается не сильно длиннее, чем на питоне:

Public Declare Function URLDownloadToFile Lib "urlmon" Alias _ "URLDownloadToFileA" (ByVal pCaller As Long, _ ByVal szURL As String, _ ByVal szFileName As String, _ ByVal dwReserved As Long, _ ByVal lpfnCB As Long) As Long ' http://site.ru/images/site/site_ru_logo.png Sub Start() Call DownloadToFile("http://site.ru/images/site/site_ru_logo.png", "D:\123.png") End Sub Public Sub DownloadToFile(url$, FileName$) Dim lngRetVal& lngRetVal = URLDownloadToFile(0, url, FileName, 0, 0) If lngRetVal <> 0 Then MsgBox "Error in DownloadToFile: Can't download from " & url & " to " & FileName End If End Sub

Как скачать файл из интернета по ссылке

Вся суть статьи уже в заголовке. Возникает порой необходимость скачивания файлов из интернета только на основании ссылки. Например, это какие-то постоянно меняющиеся данные или автоматически генерируемая другим кодом ссылка. Или еще более усугубленный вариант — строк 100 со ссылками на файлы, которые надо скачать. Вот уж радости руками по каждой клацать 🙂
Поэтому выкладываю решение, которое в большинстве случае поможет при помощи Visual Basic for Applications скачать файл на основании ссылки URL:

'--------------------------------------------------------------------------------------- ' File : mDownloadFileFromURL ' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке '--------------------------------------------------------------------------------------- Option Explicit 'объявление функции API - URLDownloadToFile ' работает на любых ПК под управлением ОС Windows ' на MAC код работать не будет #If Win64 Then 'для операционных систем с 64-разрядной архитектурой Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong #Else #If VBA7 Then 'для любых операционных систем с офисом 2010 и выше Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr #Else 'для 32-разрядных операционных систем Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If #End If 'переменная для хранения пути к папке Dim sFilePath As String Function CallDownload(sFileURL As String, sFileName As String) ' sFileURL - ссылка URL для скачивания файла ' sFileName - имя файла с расширением, которое будет присвоено после скачивания Dim h If sFilePath = "" Then 'диалоговое окно выбора папки 'подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/ With Application.FileDialog(msoFileDialogFolderPicker) If .Show = False Then Exit Function End If sFilePath = .SelectedItems(1) End With End If If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\" 'проверяем есть ли файл с таким же именем в выбранной папке If Dir(sFilePath & sFileName, 16) = "" Then 'файла нет - скачиваем h = DownloadFileAPI(sFileURL, sFilePath & sFileName) Else 'файл есть - запрос на перезапись If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then 'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно 'отменяем загрузку If IsBookOpen(sFileName) Then MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _ vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else h = DownloadFileAPI(sFileURL, sFilePath & sFileName) End If End If End If CallDownload = h End Function 'функция скачивания файла в выбранную папку Function DownloadFileAPI(sFileURL, ToPathName) ' sFileURL - ссылка URL для скачивания файла ' ToPathName - полный путь с именем файла для сохранения Dim h Dim sFilePath As String Dim sFileName As String 'вызов функции API для непосредственно скачивания h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0) 'если h = False - файл не удалось скачать, показываем инф.окно If h = False Then MsgBox "Невозможно скачать файл." & vbNewLine & _ "Возможно, у Вас нет прав на создание файлов в выбранной директории." & vbNewLine & _ "Попробуйте выбрать другую папку для сохранения", vbInformation, "www.excel-vba.ru" Exit Function Else 'файл успешно скачан sFileName = Dir(ToPathName, 16) sFilePath = Replace(ToPathName, sFileName, "") If MsgBox("Файл сохранен в папку: " & sFilePath & _ vbNewLine & "Открыть файл сейчас?", vbYesNo, "www.excel-vba.ru") = vbYes Then If IsBookOpen(sFileName) Then MsgBox "Файл с именем '" & sFileName & "' уже открыт. Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else Workbooks.Open ToPathName End If End If End If DownloadFileAPI = h End Function 'Функция проверки - открыта ли книга с заданным именем 'подробнее: ' http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/ Function IsBookOpen(wbName As String) As Boolean Dim wbBook As Workbook For Each wbBook In Workbooks If Windows(wbBook.Name).Visible Then If wbBook.Name = wbName Then IsBookOpen = True: Exit For End If Next wbBook End Function

‘————————————————————————————— ‘ File : mDownloadFileFromURL ‘ Purpose: код позволяет скачивать файлы из интернета по указанной ссылке ‘————————————————————————————— Option Explicit ‘объявление функции API — URLDownloadToFile ‘ работает на любых ПК под управлением ОС Windows ‘ на MAC код работать не будет #If Win64 Then ‘для операционных систем с 64-разрядной архитектурой Declare PtrSafe Function URLDownloadToFile Lib «urlmon» Alias «URLDownloadToFileA» _ (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong #Else #If VBA7 Then ‘для любых операционных систем с офисом 2010 и выше Declare PtrSafe Function URLDownloadToFile Lib «urlmon» Alias «URLDownloadToFileA» _ (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr #Else ‘для 32-разрядных операционных систем Declare Function URLDownloadToFile Lib «urlmon» Alias «URLDownloadToFileA» _ (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If #End If ‘переменная для хранения пути к папке Dim sFilePath As String Function CallDownload(sFileURL As String, sFileName As String) ‘ sFileURL — ссылка URL для скачивания файла ‘ sFileName — имя файла с расширением, которое будет присвоено после скачивания Dim h If sFilePath = «» Then ‘диалоговое окно выбора папки ‘подробнее: http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/ With Application.FileDialog(msoFileDialogFolderPicker) If .Show = False Then Exit Function End If sFilePath = .SelectedItems(1) End With End If If Right(sFilePath, 1) <> «\» Then sFilePath = sFilePath & «\» ‘проверяем есть ли файл с таким же именем в выбранной папке If Dir(sFilePath & sFileName, 16) = «» Then ‘файла нет — скачиваем h = DownloadFileAPI(sFileURL, sFilePath & sFileName) Else ‘файл есть — запрос на перезапись If MsgBox(«Этот файл уже существует в папке: » & sFilePath & vbNewLine & «Перезаписать?», vbYesNo, «www.excel-vba.ru») = vbYes Then ‘если существующий файл открыт — невозможно его перезаписать, показываем инф.окно ‘отменяем загрузку If IsBookOpen(sFileName) Then MsgBox «Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл ‘» & sFileName & «‘ и этот файл открыт.» & _ vbNewLine & «Закройте открытый файл и повторите попытку.», vbCritical, «www.excel-vba.ru» Else h = DownloadFileAPI(sFileURL, sFilePath & sFileName) End If End If End If CallDownload = h End Function ‘функция скачивания файла в выбранную папку Function DownloadFileAPI(sFileURL, ToPathName) ‘ sFileURL — ссылка URL для скачивания файла ‘ ToPathName — полный путь с именем файла для сохранения Dim h Dim sFilePath As String Dim sFileName As String ‘вызов функции API для непосредственно скачивания h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0) ‘если h = False — файл не удалось скачать, показываем инф.окно If h = False Then MsgBox «Невозможно скачать файл.» & vbNewLine & _ «Возможно, у Вас нет прав на создание файлов в выбранной директории.» & vbNewLine & _ «Попробуйте выбрать другую папку для сохранения», vbInformation, «www.excel-vba.ru» Exit Function Else ‘файл успешно скачан sFileName = Dir(ToPathName, 16) sFilePath = Replace(ToPathName, sFileName, «») If MsgBox(«Файл сохранен в папку: » & sFilePath & _ vbNewLine & «Открыть файл сейчас?», vbYesNo, «www.excel-vba.ru») = vbYes Then If IsBookOpen(sFileName) Then MsgBox «Файл с именем ‘» & sFileName & «‘ уже открыт. Закройте открытый файл и повторите попытку.», vbCritical, «www.excel-vba.ru» Else Workbooks.Open ToPathName End If End If End If DownloadFileAPI = h End Function ‘Функция проверки — открыта ли книга с заданным именем ‘подробнее: ‘ http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/ Function IsBookOpen(wbName As String) As Boolean Dim wbBook As Workbook For Each wbBook In Workbooks If Windows(wbBook.Name).Visible Then If wbBook.Name = wbName Then IsBookOpen = True: Exit For End If Next wbBook End Function

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

Основная функция , отвечающая за непосредственно скачивание — это функция API(Application Programming Interface) URLDownloadToFile . Она объявлена в самом верху кода. Там есть страшные директивы вроде #If Win64 Then . Это особые директивы, которые работают даже вне процедур. Поэтому не надо удивляться, что они вне всяких Sub и тем более не надо эти Sub-ы добавлять. При этом так же не надо удивляться, если какие-то из строк внутри этих директив будут подсвечены компилятором VBA красным шрифтом. На функциональность это не повлияет.

Вызов скачивания файла происходит обычным обращением к функции CallDownload. Например, есть ссылка для скачивания: http://www.excel-vba.ru/files/book.xls . И сохранить надо под именем » Книга1.xls «. Вызываем функцию скачивания файла:

Sub DownloadFile() Call CallDownload("http://www.excel-vba.ru/files/book.xls", "Книга1.xls") 'вызываем скачивание файла End Sub

Sub DownloadFile() Call CallDownload(«http://www.excel-vba.ru/files/book.xls», «Книга1.xls») ‘вызываем скачивание файла End Sub

Функция сама запросит папку для сохранения файла и после скачивания предложит открыть этот файл. Если такой файл уже есть — будет предложено его перезаписать.
К статье приложен файл, в котором код чуть расширен — он позволяет скачивать файлы сразу из множества ячеек, проставляя при этом признак — скачан файл или нет. И если сразу весь список обработать не получилось и какие-то файлы не удалось скачать(например, имена совпадали, а заменять файлы не надо было), то в этом случае можно будет повторно запустить код и скачиваться будут лишь те, у которых нет статуса » Скачан! «.
Так же, т.к. ячеек много, перед скачиванием файлов будет выбор — запрашивать ли открытие файлов после скачивания или нет. Если открывать не надо, следует ответить Нет. Тогда файлы просто будут скачаны в указанную папку. Однако, если в этой папке будут расположены файлы с идентичными именами — запрос на перезапись все же появится, при этом для каждого файла. Если подобный запрос так же мешает, то надо этот блок:

'проверяем есть ли файл с таким же именем в выбранной папке If Dir(sFilePath & sFileName, 16) = "" Then 'файла нет - скачиваем h = DownloadFileAPI(sFileURL, sFilePath & sFileName) Else 'файл есть - запрос на перезапись If MsgBox("Этот файл уже существует в папке: " & sFilePath & vbNewLine & "Перезаписать?", vbYesNo, "www.excel-vba.ru") = vbYes Then 'если существующий файл открыт - невозможно его перезаписать, показываем инф.окно 'отменяем загрузку If IsBookOpen(sFileName) Then MsgBox "Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл '" & sFileName & "' и этот файл открыт." & _ vbNewLine & "Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else h = DownloadFileAPI(sFileURL, sFilePath & sFileName) End If End If End If

‘проверяем есть ли файл с таким же именем в выбранной папке If Dir(sFilePath & sFileName, 16) = «» Then ‘файла нет — скачиваем h = DownloadFileAPI(sFileURL, sFilePath & sFileName) Else ‘файл есть — запрос на перезапись If MsgBox(«Этот файл уже существует в папке: » & sFilePath & vbNewLine & «Перезаписать?», vbYesNo, «www.excel-vba.ru») = vbYes Then ‘если существующий файл открыт — невозможно его перезаписать, показываем инф.окно ‘отменяем загрузку If IsBookOpen(sFileName) Then MsgBox «Невозможно сохранить файл в указанную папку, т.к. она уже содержит файл ‘» & sFileName & «‘ и этот файл открыт.» & _ vbNewLine & «Закройте открытый файл и повторите попытку.», vbCritical, «www.excel-vba.ru» Else h = DownloadFileAPI(sFileURL, sFilePath & sFileName) End If End If End If

заменить на всего одну строку:

h = DownloadFileAPI(sFileURL, sFilePath & sFileName)

h = DownloadFileAPI(sFileURL, sFilePath & sFileName)

Следует учитывать, что при этом можно потерять какие-то важные файлы. Поэтому подобные вещи вы делаете на свой страх и риск.

Так же всегда надо помнить еще одну вещь: не все сайты вот так запросто разрешают скачивать с них файлы, тем более пачками. Особенно это актуально для всякого рода форексов, сайтов с результатами матчей, котировками и иже с ними. Возможно, получится скачать один, два, три — десять файлов. Но всегда может случиться так, что сайт просто заблокирует ваш IP до конца дня, т.к. на сайте установлено ограничение на автоматизированное обращение извне. А где-то еще и капчу могут запросить. При этом для разных сайтов решение данной проблемы может быть различным и не всегда решаемым

Статья помогла? Поделись ссылкой с друзьями!