Как сохранить картинки из листа Excel в картинки JPG
Получили по почте файл-прайс с изображениями товара и эти картинки нужны в отдельной папки, а не на листе? Например для загрузки на сайт. Или для других целей. Подобной команды в Excel нет. Вставить картинки можно, а вот обратно к сожалению никак. Хорошо, если картинок штук 10, а если 100? А если таких книг много? И из всех надо сохранить картинки? Решил поделиться кодами, которые могут сохранять картинки из листа Excel в папку.
Если не знаете как применять коды Visual Basic for Applications, то настоятельно рекомендую к прочтению эти статьи:
Что такое макрос и где его искать?
Что такое модуль? Какие бывают модули?
Если хотите использовать один из нижеприведенных кодов, то следует создать стандартный модуль, скопировать нужные код и вставить его в этот модуль.
- Сохранение выделенной картинки в файл
- Сохранение всех картинок из всех выбранных файлов Excel в папку
- Сохранить выделенный диапазон в картинку
- Сохраняем все картинки с листа в папку с записью в ячейки имен картинок
- Сохранить картинки с листа с именами картинок из ячеек
Все, что потребуется это выделить объект/картинку и выполнить нижеприведенный код:
Sub Save_Sel_Object_As_Picture() Dim sName As String, oObj As Object, wsTmpSh As Worksheet If VarType(Selection) <> vbObject Then MsgBox "Выделенная область не является объектом!", vbCritical, "www.excel-vba.ru" Exit Sub End If Application.ScreenUpdating = False Application.DisplayAlerts = False Set oObj = Selection: oObj.Copy Set wsTmpSh = ThisWorkbook.Sheets.Add sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_" & oObj.Name With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart .ChartArea.Border.LineStyle = 0 .Parent.Select .Paste .Export Filename:=sName & ".gif", FilterName:="GIF" .Parent.Delete End With wsTmpSh.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub |
Если необходимо сохранить не только картинки, но и другие объекты, то необходимо в коде в строке:
Sub Save_Object_As_Picture() Dim avFiles, li As Long, oObj As Object, wsSh As Worksheet, wsTmpSh As Worksheet Dim sImagesPath As String, sBookName As String, sName As String Dim wbAct As Workbook Dim IsForEachWbFolder As Boolean avFiles = Application.GetOpenFilename("Excel Files(*.xls*),*.xls*", , "Выбрать файлы", , True) If VarType(avFiles) = vbBoolean Then Exit Sub IsForEachWbFolder = (MsgBox("Сохранять картинки каждой книги в отдельную папку?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes) If Not IsForEachWbFolder Then sImagesPath = Environ("userprofile") & "\desktop\images\" '" If Dir(sImagesPath, 16) = "" Then MkDir sImagesPath End If End If On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False Set wsTmpSh = ThisWorkbook.Sheets.Add For li = LBound(avFiles) To UBound(avFiles) Set wbAct = Workbooks.Open(avFiles(li), False) 'создаем папку для сохранения картинок If IsForEachWbFolder Then sImagesPath = wbAct.Path & "\" & wbAct.Name & "_images\" If Dir(sImagesPath, 16) = "" Then MkDir sImagesPath End If End If sBookName = wbAct.Name For Each wsSh In Sheets For Each oObj In wsSh.Shapes If oObj.Type = 13 Then '13 - картинки '1 - автофигуры '3 - диаграммы oObj.Copy sName = ActiveWorkbook.Name & "_" & wsSh.Name & "_" & oObj.Name With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart .ChartArea.Border.LineStyle = 0 .Parent.Select .Paste .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG" .Parent.Delete End With End If Next oObj Next wsSh wbAct.Close 0 Next li Set oObj = Nothing: Set wsSh = Nothing wsTmpSh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Объекты сохранены", vbInformation, "www.excel-vba.ru" End Sub |
Код позволяет выбрать одну или несколько книг Excel и сохраняет все картинки со всех листов выбранных книг. При запуске кода предлагается выбрать файлы Excel, картинки из которых надо сохранить. После этого появится запрос: "Сохранять картинки каждой книги в отдельную папку?"
- Да - для каждой книги будет создана своя папка images, в которую будут сохранены картинки с именами вида: ИмяКниги_ИмяЛиста_ИмяФигуры
- Нет - на рабочем столе пользователя будет создана папка images, в которую будут сохранены картинки с именами вида: ИмяКниги_ИмяЛиста_ИмяФигуры
Если необходимо сохранить не только картинки, но и другие объекты, то необходимо в коде в строке:
Данные код сохраняет выделенный на листе диапазон в картинку.
Sub Range_to_Picture() Dim sName As String, wsTmpSh As Worksheet If TypeName(Selection) <> "Range" Then MsgBox "Выделенная область не является диапазоном!", vbCritical, "www.excel-vba.ru" Exit Sub End If Application.ScreenUpdating = False Application.DisplayAlerts = False With Selection .CopyPicture Set wsTmpSh = ThisWorkbook.Sheets.Add sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range" With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart .ChartArea.Border.LineStyle = 0 .Parent.Select .Paste .Export Filename:=sName & ".gif", FilterName:="GIF" .Parent.Delete End With End With wsTmpSh.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub |
Просто выделяем диапазон, который необходимо сохранить как картинку и запускаем код. Картинка будет сохранена в папку с активной книгой.
Код ниже сохраняет все картинки на активном листе в папку
Sub Save_Object_As_Picture() Dim li As Long, oObj As Shape, wsSh As Worksheet, wsTmpSh As Worksheet Dim sImagesPath As String, sName As String sImagesPath = ActiveWorkbook.Path & "\images\" '" If Dir(sImagesPath, 16) = "" Then MkDir sImagesPath End If On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False Set wsSh = ActiveSheet Set wsTmpSh = ActiveWorkbook.Sheets.Add For Each oObj In wsSh.Shapes If oObj.Type = 13 Then li = li + 1 oObj.Copy sName = "img" & li With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart .ChartArea.Border.LineStyle = 0 .Parent.Select .Paste .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG" .Parent.Delete End With oObj.TopLeftCell.Value = sName oObj.Delete 'удаляем картинку с листа End If Next oObj Set oObj = Nothing: Set wsSh = Nothing wsTmpSh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Объекты сохранены в папке: " & sImagesPath, vbInformation, "www.excel-vba.ru" End Sub |
В коде все так же, как в кодах выше(можно сохранять другие объекты, можно изменить формат сохраняемых картинок). Только при этом в ячейку, в которой была картинка записывается имя, с которым эта картинка была сохранена в папку на компьютере. Сама картинка при этом удаляется. Если удалять не надо, то необходимо просто удалить строку:
Если необходимо записать в ячейку не только имя картинки, но и полный путь(включая путь к папке и расширение картинки), то надо вместо строки:
записать такую:
Пожалуй, самый популярный код. Он сохраняет картинки из активного листа с именами, взятыми из ячеек, в которых эти картинки расположены. При этом можно указать, чтобы имена брались из той же строки, но другого столбца:
Sub Save_Object_As_Picture_NamesFromCells() Dim li As Long, oObj As Shape, wsSh As Worksheet, wsTmpSh As Worksheet Dim sImagesPath As String, sName As String Dim lNamesCol As Long, s As String s = InputBox("Укажите номер столбца с именами для картинок" & vbNewLine & _ "(0 - столбец в котором сама картинка)", "www.excel-vba.ru", "") If StrPtr(s) = 0 Then Exit Sub lNamesCol = Val(s) sImagesPath = ActiveWorkbook.Path & "\images\" '" If Dir(sImagesPath, 16) = "" Then MkDir sImagesPath End If ' On Error Resume Next Application.ScreenUpdating = False Application.DisplayAlerts = False Set wsSh = ActiveSheet Set wsTmpSh = ActiveWorkbook.Sheets.Add For Each oObj In wsSh.Shapes If oObj.Type = 13 Then oObj.Copy If lNamesCol = 0 Then sName = oObj.TopLeftCell.Value Else sName = wsSh.Cells(oObj.TopLeftCell.Row, lNamesCol).Value End If 'если в ячейке были символы, запрещенные 'для использования в качестве имен для файлов - удаляем sName = CheckName(sName) 'если sName в результате пусто - даем имя unnamed_ с порядковым номером If sName = "" Then li = li + 1 sName = "unnamed_" & li End If With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart .ChartArea.Border.LineStyle = 0 .Parent.Select .Paste .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG" .Parent.Delete End With End If Next oObj Set oObj = Nothing: Set wsSh = Nothing wsTmpSh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "Объекты сохранены в папке: " & sImagesPath, vbInformation, "www.excel-vba.ru" End Sub '--------------------------------------------------------------------------------------- ' Procedure : CheckName ' Purpose : Функция проверки правильности имени '--------------------------------------------------------------------------------------- Function CheckName(sName As String) Dim objRegExp As Object Dim s As String Set objRegExp = CreateObject("VBScript.RegExp") objRegExp.Global = True: objRegExp.IgnoreCase = True objRegExp.Pattern = "[:,\\,/,?,\*,\<,\>,\',\|,""""]" s = objRegExp.Replace(sName, "") CheckName = s End Function |
Укажите номер столбца с именами для картинок - указывается порядковый номер столбца на листе, из которого брать имя для сохраняемой картинки. Например, сами картинки в столбце H, а имена для них записаны в столбце B. Надо указать 2. Тогда для картинки в ячейке H3 будет использовано имя, записанное в ячейке В3. Расширение для картинки указывать не надо(например -
Если номер не указывать или указать 0 - то имя для картинок будет взято из тех ячеек, в которых находятся эти картинки.
Так же проверяется корректность значений в ячейках, т.к. они могут содержать символы, недопустимые в именах файлов(слеши и пр.). В этом случаи эти символы будут удалены. И если после удаления этих символов значение будет пустым - имена картинкам будут даваться с префиксом
Tips_Macro_Save_Object_As_Picture.xls (76,0 KiB, 15 327 скачиваний)
Также см.:
Сохранить диаграммы в графический файл
Сохранение выделенного диапазона в графический файл
Как скопировать картинку из примечания?
Статья помогла? Поделись ссылкой с друзьями!
Поиск по меткам
Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистикаКомментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум
я скачала пример, нажимаю: "выбрать книгу с картинками", открываются мои библиотеки, выбираю нужный мне прайс, но он не появляется нигде, нажимаю кнопку "посмотреть код", загружается, потом сохраняется где-то и не могу найти
А где у Вас книга с кодом сохранена? Прямо с сайта открывали? Статью читали полностью? Внизу написано: "сохраняет все картинки со всех листов выбранных книг в папку с книгой, в которой расположен данный код"
Есть способ намного проще и нетребующий навыков программирования.
Чтобы выгрузить картинки из EXCEL книги нужно ее сохранить как WEB страницу.
Файл-Сохранить как - Веб страница (*.htm,*.html)
и тогда по пути где находится наш файл будет создана папка
ИМЯНАШЕГОФАЙЛА.files открываем ее и видим все нужные нам картинки.
Все гениальное - просто.
Tatitutu, способ хороший и мне известен, но. Только если надо сохранить картинки из одной книги. Как сработает быстро Ваш вариант, если таких книг с картинками более 10? :-) Открывать каждую и сохранять как-то не очень быстро, кажется...
Дмитрий, я не сколько не сомневаюсь в ваших знаниях.
Просто предложил альтернативу быструю.
Что значит "Открывать каждую ...как то не очень быстро " ??????
т.е. вы в вашем коде "Workbooks.Open avFiles(li)" не открываете файлы так . Замечательно.
Не быстрее будет тогда
укажите папку
перебрать все файлы
пересохранить
выбрать все неодинаковые картинки
и сохранить в одной папке.
Я даже спорить не собираюсь. Я написал, что способ Ваш актуален для одной книги. Я Вам не навязываю свой код. Не нравится - пользуйтесь своим методом. Но лично мне кажется, что просто нажать кнопку и выбрать несколько книг и получить результат несколько быстрее, чем открывать каждую отдельно и пересохранять. Но Вам виднее....
И да: то, что предлагаете Вы(указать, перебрать, пересохранить и т.д.) - будет никак не быстрее. И к тому же: проведите эксперимент. Создайте две новых книги. Вставьте в каждую из них по картинке. Имена картинок будут совпадать: Рисунок 1 и Рисунок 1. Но рисунки разные. Сохраните как веб-страницу. И тогда Ваше "выбрать все неодинаковые картинки" выберет только одну из них. Плюс к этому при подобном сохранении происходит задвоение картинок при одинаковом содержимом. Это тоже можно обойти, но опять же - это усложняет код(может даже значительно, т.к. не очень просто объяснить программе, что разные имена картинок не означает, что изображение на картинке одно) и никак не ускорит.
Так что повторюсь: Ваш метод хорош при сохранении из одной книги. Хорош многим, а в особенности в том, что не требуется кодов и каких-то навыков.
Дмитрий, а можно сократить код - обойтись без Copy-Paste? Т.е. как то обратиться к объекту после изменения размера его тут же сохранить. У меня на файле с несколькими тысячами картинок выгрузка занимает до часа. А процедура ежедневная. Поэтому любая экономия на операциях даствыигрыш. Да и при использовании вашего кода где то иногда происходит непонятный сбой и часть картинок выгружаются пустыми (хотя в другой раз - опять нормально).
запускаю ваш скрипт, а в папку сохраняется только первая картинка. и можно ли чтобы имя картинки совпадало с 1ым столбцом в экселе?
Не могу подсказать, почему сохраняется лишь одна картинка. Проверил - все сохраняет. По поводу совпадало: так, как поставлен Ваш вопрос ответ такой: можно, назначьте имена картинкам на листе в соответствии с 1-ым столбцом. Если еще будут подобные вопросы - обращайтесь вфорум (об этом написано внизу страницы).
Извините Дмитрий (не нашел ветки в форуме по данной теме в блоге) есть две проблемы
описанные выше: 1 - сохраняется только одна картинка (проблема в замещении картинки) и 2 называть картинки по первой колонки листа или наименовании ячейки! подскажите по ним здесь или создайте ветку в форуме.
С уважением Юрий