Lost your password?


Хитрости »
Основные понятия (27)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (23)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (68)
Разное (43)
Баги и глюки Excel (5)

Как сохранить картинки из листа Excel в картинки JPG

Получили по почте файл-прайс с изображениями товара и эти картинки нужны в отдельной папки, а не на листе? Например для загрузки на сайт. Или для других целей. Подобной команды в Excel нет. Вставить картинки можно, а вот обратно к сожалению никак. Хорошо, если картинок штук 10, а если 100? А если таких книг много? И из всех надо сохранить картинки? Решил поделиться кодами, которые могут сохранять картинки из листа Excel в папку.
Если не знаете как применять коды Visual Basic for Applications, то настоятельно рекомендую к прочтению эти статьи:
Что такое макрос и где его искать?
Что такое модуль? Какие бывают модули?
Если хотите использовать один из нижеприведенных кодов, то следует создать стандартный модуль, скопировать нужные код и вставить его в этот модуль.


 
Сохранение выделенной картинки в файл
Все, что потребуется это выделить объект/картинку и выполнить нижеприведенный код:

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

Если необходимо сохранить не только картинки, но и другие объекты, то необходимо в коде в строке: If oObj.Type = 13 Then изменить цифру. В коде комментариями указано, какая цифра какой тип обозначает. Так же можно изменить и расширение итогового файла с ".gif" на ".jpg". Достаточно найти расширение gif в коде(в двух местах) и заменить их на jpg. Если ни один объект не выделен, то ничего не произойдет.



 
Сохранение всех картинок из всех выбранных файлов Excel в папку

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, в которую будут сохранены картинки с именами вида: ИмяКниги_ИмяЛиста_ИмяФигуры

Если необходимо сохранить не только картинки, но и другие объекты, то необходимо в коде в строке: If oObj.Type = 13 Then изменить цифру. В коде комментариями указано, какая цифра какой тип обозначает. Так же можно изменить и расширение итогового файла с ".jpg" на ".gif". Достаточно найти расширение jpg в коде(в двух местах) и заменить их на gif. В данном коде я намеренно сделал сохранение в формат jpg, чтобы можно было сравнить с предыдущим кодом и увидеть как правильно менять расширение(формат) файла.



 
Сохранить выделенный диапазон в картинку
Данные код сохраняет выделенный на листе диапазон в картинку.

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

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



 
СОХРАНЯЕМ ВСЕ КАРТИНКИ С ЛИСТА В ПАПКУ С ЗАПИСЬЮ В ЯЧЕЙКИ ИМЕН КАРТИНОК
Картинки на текст
Код ниже сохраняет все картинки на активном листе в папку images, которая создается в папке с книгой Excel, картинки из которой сохраняются. Если папки images нет - она будет создана. Картинкам даются имена "img1", "img2", "img3" и т.д. Картинки из ячеек удаляются, а на их место записывается имя картинки. Актуально, наверное, для тех, кто из таких файлов делает потом выгрузки в интернет-магазины и пр.

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

В коде все так же, как в кодах выше(можно сохранять другие объекты, можно изменить формат сохраняемых картинок). Только при этом в ячейку, в которой была картинка записывается имя, с которым эта картинка была сохранена в папку на компьютере. Сама картинка при этом удаляется. Если удалять не надо, то необходимо просто удалить строку:
oObj.Delete 'удаляем картинку с листа
Если необходимо записать в ячейку не только имя картинки, но и полный путь(включая путь к папке и расширение картинки), то надо вместо строки:
oObj.TopLeftCell.Value = sName
записать такую:
oObj.TopLeftCell.Value = sImagesPath & sName & ".jpg"



 
Сохранить картинки с листа с именами картинок из ячеек
Пожалуй, самый популярный код. Он сохраняет картинки из активного листа с именами, взятыми из ячеек, в которых эти картинки расположены. При этом можно указать, чтобы имена брались из той же строки, но другого столбца:

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. Расширение для картинки указывать не надо(например - image1, image2, image_product_sell1 и т.п.).
Если номер не указывать или указать 0 - то имя для картинок будет взято из тех ячеек, в которых находятся эти картинки.
Так же проверяется корректность значений в ячейках, т.к. они могут содержать символы, недопустимые в именах файлов(слеши и пр.). В этом случаи эти символы будут удалены. И если после удаления этих символов значение будет пустым - имена картинкам будут даваться с префиксом "unnamed_" и порядковым номером таких картинок.

Скачать пример

  Tips_Macro_Save_Object_As_Picture.xls (76,0 KiB, 15 327 скачиваний)

Также см.:
Сохранить диаграммы в графический файл
Сохранение выделенного диапазона в графический файл
Как скопировать картинку из примечания?


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

Поиск по меткам

Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистика
Обсуждение: 105 комментариев
  1. Стесняюсь спросить - а какого Александра Вы просите показать код? И почему так категорично? Он Вам чем-то обязан, надо полагать?

    • gde-site:

      Стесняюсь даже отвечать.. какого черта про Александра написал. За категоричность извините - Вы, Дмитрий, конечно, ничего нам не должны. Просто обычно отвечаете в течение суток, а тут дни идут - надежда тает( Будьте так любезны и просветите нас, как бы решить задачу с захватом имен файлов из соседних ячеек с картинками.

  2. Николай:

    Здравствуйте, Дмитрий!
    Помогите, пожалуйста: сохраняется лишь первое изображение, вместо остальных - белые (пустые) картинки. Та же самая ситуация и при использовании надстройки, код которой, должно быть, известен Александру.

  3. Спасибо автору. Все получилось. Единственное, не помешало бы более подробное описание по принципу применения кода для полных чайников. Пришлось погреть голову прежде чем картинки оказались там где нужно.:)

  4. Вася:

    Такой вопрос - а что если для oObj.TopLeftCell.Address попадается 2 и более картинок (т.е., к примеру, у двух картинок anchor ячейки совпадает)? У меня в результате этом сохраняется только одна, а желательно чтобы они сохранялись все по индексу, либо выбор какой-то, к примеру - самую большую по произведению высоты на ширину или что-то подобное.

  5. Александр:

    Здравствуйте, Дмитрий!
    Помогите, пожалуйста: Как из активного листа сделать .png файл
    В идеале .pdf но целиком как картинка, как будто оригинал распечатали и отсканировали!

  6. asken questa:

    Здравствуйте, а в чем может быть проблема - при сохранении файлов в виде jpg-картинок они все получаются белого цвета? Т.е. размеры сохраняются, но при этом внутри они целиком белые :-(

    • asken questa, подскажите какой именно код используется, какая версия офиса и ОС? Спасибо.

      • Сергей:

        Доброе время. Также получаются белые картинки. ОС Win10, Office 2016.

        • Сергей, ну и Вам тот же вопрос: какой код используется? Раз у Вас есть эта ошибка - напишите в каком из приложенных кодов, тогда я смогу хотя бы ошибку найти. Спасибо.

          • Сергей:

            Вот этот код "СОХРАНИТЬ КАРТИНКИ С ЛИСТА С ИМЕНАМИ КАРТИНОК ИЗ ЯЧЕЕК"

          • Сергей, 2016 офиса нет, но есть 365. Там все работает нормально, только что проверил. Попробуйте вместо этой строки:
            If oObj.Type = 13 Then
            записать такую:
            If oObj.Type = oObj.Type Then
            чтобы код сохранял ВСЕ объекты, а не только те, у которых внутренний тип картинка. Если при этом опять же все будут сохраняться белыми - будем думать дальше и искать пути решения для конкретных версий офиса.

          • Сергей:

            Дмитрий.Будет ответ?

  7. Сергей, Вам не кажется, что Ваш вопрос звучит как-то слишком нагло? :) Я же вроде Вам ничего не должен, чтобы в подобной требовательной манере с меня спрашивать. Понимаю, что вряд ли предполагался такой тон, но все же старайтесь как-то подбирать слова - я ведь не обязан все проблемы с кодами на сайте(которые я предоставляю бесплатно), решать оперативно и по требованию. У меня же есть и работа, которую надо работать, как ни странно :)
    По сути: это проблема версий офиса, начиная с 2013. До причин, равно как и устранения самой проблемы, пока не добрался - на это больше времени нужно. Как только решу вопрос - сразу выложу, не переживайте. Я понимаю, что вопрос животрепещущий - но и я не имею возможности сидеть и часами устранять проблемы, которые Microsoft так лихо подкидывает невзначай :)

    • Александр:

      Дмитрий, добрый день, некоторое время использовал макрос, который вероятно взят у вас, для сохранения картинки в отдельный файл, но после обновления офиса до 365 тоже файл стал сохраняться просто как белое поле. Я приведу весь макрос, вдруг будет проще понять ошибку

      Sub screenshot()
          Dim sName As String, wsTmpSh As Worksheet, S, sss
          Application.ScreenUpdating = False
          Application.DisplayAlerts = False
          Sheets("названия листа").Select
          Range("C2:N18").Select
          With Selection
              .CopyPicture
              Set wsTmpSh = ThisWorkbook.Sheets.Add
              sName = "путь к папке для экспорта картинки" & "_" & Date - 1 & "_" & Hour(Time) & "_" & Minute(Time) & "_" & Second(Time) '"
              With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
                  .ChartArea.Border.LineStyle = 0
                  .Paste
                  .Export Filename:=sName & ".jpg", FilterName:="JPG"
                  .Parent.Delete
              End With
          End With
          wsTmpSh.Delete
          Application.ScreenUpdating = True
          Application.DisplayAlerts = True
      Range("R5").Select
      End Sub

      Буду благодарен, если удастся найти ошибку.

      • Правильно Ваш код должен выглядеть так:

        Sub screenshot()
            Dim sName As String, wsTmpSh As Worksheet, S, sss
            Dim rr As Range
         
            Application.ScreenUpdating = False
            Set rr = Range("C2:N18")
            rr.CopyPicture xlPrinter
            Set wsTmpSh = ThisWorkbook.Sheets.Add
            wsTmpSh.PasteSpecial
            Selection.Copy
            sName = ThisWorkbook.Path & "" & "_" & Date - 1 & "_" & Hour(Time) & "_" & Minute(Time) & "_" & Second(Time) '"
            With wsTmpSh.ChartObjects.Add(0, 0, rr.Width, rr.Height).Chart
                .ChartArea.Border.LineStyle = 0
                .Parent.Select
                .Paste
                .Export Filename:=sName & ".jpg", FilterName:="JPG"
                .Parent.Delete
            End With
            Application.DisplayAlerts = False
            wsTmpSh.Delete
            Application.DisplayAlerts = True
            Application.ScreenUpdating = True
        End Sub
  8. Александр:

    Дмитрий, огромное Вам спасибо за Ваш ресурс и проделанную работу! Мне очень пригодился последний код для вытаскивания картинок с присвоением им имен ячеек. Вы, наверное, единственный человек, который реализовал это достаточно просто, и главное так, чтобы это работало. Желаю Вам долгих лет жизни, сил и энергии для новых начинаний и свершений.

    • Спасибо, Александр!

      • Александр:

        Дмитрий, все работало прекрасно, я по прежнему Вам благодарен, но в какой-то момент "вылазит" ошибка Run-time error '5' Invalid procedure call or argument, указывающая на строку /.Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"/

        Всегда на одном и том же месте: после прохождения 98 картинок. Пытался решить проблему изменением формата с jpg на gif или bmp, но ничего не выходит. Один раз удалось "решить" проблему прописав в строке рядом с .jpg дополнительно .gif. Ошибка больше не выскакивала, в папке появлялись новые файлы с разширением .jpg, .gif и размером 0 байт. Самостоятельно проблему, увы, решить не удалось, может быть вы можете подсказать в чем проблема? Буду признателен безмерно, если поможете, поскольку без работы этого макроса уйдет уйма человеко-часов на перенос и правильное наименование картинок.

        Файл загрузил на dropbox:
        https://www.dropbox.com/s/c8qk1d09n53u8ek/E60.xls?dl=0

  9. Виталий:

    Я по поводу "СОХРАНЯЕМ ВСЕ КАРТИНКИ С ЛИСТА В ПАПКУ С ЗАПИСЬЮ В ЯЧЕЙКИ ИМЕН КАРТИНОК".
    Мне очень понравился код, спасибо автору. Только этот метод не подходит для интернет магазинов. Сохраняется не полный объём картинки, а превью. Но спасти ситуацию можно, если картинку вставили, уменьшили и не обрезали. В этом случае полная копия хранится в самом файле Excel. Сделайте копию этого файла. Затем переименуйте Excel файл: расширение XLS или xlsx переименовать в zip. Затем полученный файл разархивируйте в какую-нибудь папку. Картинки вы найдете по пути ...\xl\media. Замените те картинки которые Вы получили с помощью кода на их более полную версию.
    Повторюсь, это сработает, если картинки в файле не сжимали.

    • Dmitry:

      Касательно того, что макрос сохраняет превьюшки изображений.
      Не обязательно для получения полных изображений "взламывать" excel файл. Просто при копировании изображение копируется текущего размера а не оригинального.
      Если изображения не сжимались, то попробуйте перед копированием изображения объекта shape обратиться к методу scalewidth и scaleheight для получения оригинальных размеров картинки (не забудьте сохранить прошлые размеры, чтобы их можно было восстановить после копирования). И с данными размерами создавайте Chart.

  10. Евгений:

    Подскажите пожалуйста, можно ли изменить макрос СОХРАНИТЬ КАРТИНКИ С ЛИСТА С ИМЕНАМИ КАРТИНОК ИЗ ЯЧЕЕК так, что бы имена складывались из двух ячеек? Например из 1, пробел, 2? Как будет выглядеть код макроса?

Поделитесь своим мнением

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


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2024 Excel для всех   Войти