Excel to jpg vba

Private Sub CommandButton1_Click()
Dim oTxt As Object
 For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count)
 ' you can change the sheet1 to your own choice
 saveText = cell.Text
 Open "H:Webshop_ZpiderStrukturbildene" & saveText & ".jpg" For Output As #1
 Print #1, cell.Offset(0, 1).text
 Close #1
 Next cell
End Sub

5

Not As Easy As You’d Think…

One would think that saving something as a picture file (png, jpg, etc…) inside Excel with VBA would be a pretty straightforward exercise. Unfortunately, the “Save as Picture” functionality only exists for saving images of Charts (called exporting). This leaves saving pictures of shapes, icons, and cell ranges void of any VBA automation.

However, with a little bit of creativity, we can utilize the chart object to store our desired image and use the chart object’s Export function to create the image file that we can manually generate by right-clicking and selecting Save as Picture…

In this article I’ll walk you through the basic concept of what the VBA code is doing and also go through two VBA macro examples pertaining to saving shapes/icons and cell ranges in various file formats.

Methodology

Not many people know this but Charts can actually store shapes/objects inside of them. For example, if you have ever copied a textbox and pasted it while a chart is selected, you’ll notice the textbox object appears to be grouped with the chart. Meaning, if you move the chart to a different location, the textbox would move right along with it. What is actually occurring is the textbox is getting embedded within the chart and is essentially now a component of the chart object (think legend, chart title, chart series, axis, etc…).

The fact that charts in Excel can absorb other objects is what we will be utilizing to workaround the fact that shapes and other objects cannot be saved as a picture in VBA.

Before we dive into the VBA code, the concept the macro will be utilizing will be to isolate the object you want to save as a picture file and also generating a blank/empty chart object.

With those two objects in place, the VBA code will simply paste the desired object into the Chart Object (kind of like converting it into a chart!).

With this concept in mind, let’s take a look at the VBA code I’ve proposed to get this job done!

Save Shape As A PNG File [VBA Code]

Hopefully the following VBA macro is easily to follow along, but I’ll outline essentially the steps it is doing so you can customize it accordingly if needed.

1. Determine if a shape is selected, if not, don’t proceed. Store the selected shape to a variable (ActiveShape)

2. Generate a Chart Object that is the exact same size as the selected shape

3. Remove the chart’s Fill and Border to make the background transparent

4. Copy the selected shape and Paste it into the Chart Object

5. Export the Chart Object as a PNG file and save to the user’s desktop

6. Delete the chart so it appears like nothing has occurred to the user

Sub SaveShapeAsPicture()
‘PURPOSE: Save a selected shape/icon as a PNG file to computer’s desktop
‘SOURCE: www.thespreadsheetguru.com

Dim cht As ChartObject
Dim ActiveShape As Shape
Dim UserSelection As Variant

‘Ensure a Shape is selected
  On Error GoTo NoShapeSelected
    Set UserSelection = ActiveWindow.Selection
    Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
  On Error GoTo 0

‘Create a temporary chart object (same size as shape)
  Set cht = ActiveSheet.ChartObjects.Add( _
    Left:=ActiveCell.Left, _
    Width:=ActiveShape.Width, _
    Top:=ActiveCell.Top, _
    Height:=ActiveShape.Height)

‘Format temporary chart to have a transparent background
  cht.ShapeRange.Fill.Visible = msoFalse
  cht.ShapeRange.Line.Visible = msoFalse

    ‘Copy/Paste Shape inside temporary chart
  ActiveShape.Copy
  cht.Activate
  ActiveChart.Paste

   ‘Save chart to User’s Desktop as PNG File
  cht.Chart.Export Environ(«USERPROFILE») & «Desktop» & ActiveShape.Name & «.png»

‘Delete temporary Chart
  cht.Delete

‘Re-Select Shape (appears like nothing happened!)
  ActiveShape.Select

Exit Sub

‘ERROR HANDLERS
NoShapeSelected:
  MsgBox «You do not have a single shape selected!»
  Exit Sub

End Sub

Save Range As A JPG File [VBA Code]

Hopefully the following VBA macro is easily to follow along, but I’ll outline essentially the steps it is doing so you can customize it accordingly if needed.

1. Determine if a cell range is selected, if not, don’t proceed.

2. Copy/Paste the range as a picture and store the picture to a variable (ActiveShape)

3. Generate a Chart Object that is the exact same size as the selected shape

4. Remove the chart’s Fill and Border to make the background transparent

5. Copy the selected shape and Paste it into the Chart Object

6. Export the Chart Object as a PNG file and save to the user’s desktop

7. Delete the generated chart & picture so it appears like nothing has occurred to the user

Sub SaveRangeAsPicture()
‘PURPOSE: Save a selected cell range as a JPG file to computer’s desktop
‘SOURCE: www.thespreadsheetguru.com

Dim cht As ChartObject
Dim ActiveShape As Shape

‘Confirm if a Cell Range is currently selected
  If TypeName(Selection) <> «Range» Then
    MsgBox «You do not have a single shape selected!»
    Exit Sub
  End If

‘Copy/Paste Cell Range as a Picture
  Selection.Copy
  ActiveSheet.Pictures.Paste(link:=False).Select
  Set ActiveShape = ActiveSheet.Shapes(ActiveWindow.Selection.Name)

  ‘Create a temporary chart object (same size as shape)
  Set cht = ActiveSheet.ChartObjects.Add( _
    Left:=ActiveCell.Left, _
    Width:=ActiveShape.Width, _
    Top:=ActiveCell.Top, _
    Height:=ActiveShape.Height)

‘Format temporary chart to have a transparent background
  cht.ShapeRange.Fill.Visible = msoFalse
  cht.ShapeRange.Line.Visible = msoFalse

    ‘Copy/Paste Shape inside temporary chart
  ActiveShape.Copy
  cht.Activate
  ActiveChart.Paste

   ‘Save chart to User’s Desktop as PNG File
  cht.Chart.Export Environ(«USERPROFILE») & «Desktop» & ActiveShape.Name & «.jpg»

‘Delete temporary Chart
  cht.Delete
  ActiveShape.Delete

‘Re-Select Shape (appears like nothing happened!)
  ActiveShape.Select

End Sub

I Hope This Helped!

Hopefully, I was able to explain how you can use VBA to create image files in Excel. If you have any questions about this technique or suggestions on how to improve it, please let me know in the comments section below.

About The Author

Hey there! I’m Chris and I run TheSpreadsheetGuru website in my spare time. By day, I’m actually a finance professional who relies on Microsoft Excel quite heavily in the corporate world. I love taking the things I learn in the “real world” and sharing them with everyone here on this site so that you too can become a spreadsheet guru at your company.

Through my years in the corporate world, I’ve been able to pick up on opportunities to make working with Excel better and have built a variety of Excel add-ins, from inserting tickmark symbols to automating copy/pasting from Excel to PowerPoint. If you’d like to keep up to date with the latest Excel news and directly get emailed the most meaningful Excel tips I’ve learned over the years, you can sign up for my free newsletters. I hope I was able to provide you some value today and hope to see you back here soon! — Chris

Hi, I can give to you 2 codes. One good, 2nd great.

First is universal, but sometimes is hart to scale range of picture area:

Option Explicit
Declare Function SystemParametersInfo Lib "user32" _
      Alias "SystemParametersInfoA" (ByVal iAction As Long, _
      ByVal iParam As Long, pvParam As Any, _
      ByVal fWinIni As Long) As Long

Function FEnableFontSmoothing(SwON As Boolean) As Boolean
    FEnableFontSmoothing = SystemParametersInfo(75, SwON, 0, &H1)
End Function

Function GetFontSmoothing() As Boolean
Dim iResults As Boolean, pv As Integer
'Get font smoothing value and return true if font smoothing is turned on.
iResults = SystemParametersInfo(74, 0, pv, 0)
If pv > 0 Then
    GetFontSmoothing = True
Else
    GetFontSmoothing = False
End If
End Function

Sub Exportuj_jako_Obrazek()
Dim RngObraz As Range, oSheet As Worksheet
Dim oChart As Chart, oObraz As Picture, nazwa$
Dim Rodzaj$: Rodzaj = "png" '"bmp","jpg","gif","png")
Dim TrueType As Boolean

Application.ScreenUpdating = False
TrueType = FEnableFontSmoothing(False)
nazwa = "Test" ' lub z komórki Range("b1").Text & " " & Range("b2").Text
Set RngObraz = Selection ' lub określony Range("A1:N20")
Set oSheet = Worksheets.Add
Charts.Add

ActiveChart.Location Where:=xlLocationAsObject, name:=oSheet.name
Set oChart = ActiveChart
RngObraz.CopyPicture Appearance:=xlScreen, Format:=xlPicture
oChart.Paste
Set oObraz = Selection
If RngObraz.Cells.Count > 40 Then
    With oChart.Parent
        .Width = 1.2 * oObraz.Width
        .Height = 1.8 * oObraz.Height
    End With
End If
oChart.Export FileName:="C:Temp" & nazwa & "." & Rodzaj, FilterName:=Rodzaj

With Application
    .DisplayAlerts = False
oSheet.Delete
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
TrueType = FEnableFontSmoothing(True)
End Sub

Secound with very good quality, but ext =EMF

'to workbook
Sub EksportujDoObrazuEMF()
  Call EksportujObiektDoEMF(ActiveWindow.VisibleRange)
  MsgBox "Its done ;-)"
End Sub

'to seperate module
Option Explicit

Private Declare Function OpenClipboard Lib "User32" _
                                       (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GetClipboardData Lib "User32" _
                                          (ByVal uFormat As Long) As Long
Private Declare Function CopyEnhMetaFileA Lib "Gdi32" _
                                          (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "Gdi32" _
                                           (ByVal hdc As Long) As Long

Sub EksportujObiektDoEMF(Obj As Object)

  Dim PlikEMF, Rep  As Long

  PlikEMF = ThisWorkbook.Path & "tmp_img.emf"
  
  If Dir$(PlikEMF) <> "" Then
    Kill PlikEMF
  End If

  If Export2emf(Obj, PlikEMF) = "" Then
    MsgBox "Błąd przy eksporcie pliku !", vbCritical
  End If
End Sub

Private Function Export2emf(Objet As Object, _
                            NazwaPliku, Optional Apparence, _
                            Optional Format, Optional Size) As String

  Export2emf = NazwaPliku

  If TypeName(Objet.Parent) = "Chart" Then
    Objet.Parent.CopyPicture Apparence, Format, Size
  ElseIf TypeName(Objet) <> "Chart" Then
    Objet.CopyPicture Apparence, Format
  Else
    Objet.CopyPicture Apparence, Format, Size
  End If
  OpenClipboard 0
  If DeleteEnhMetaFile(CopyEnhMetaFileA(GetClipboardData(14), _
                                        Export2emf)) = 0 Then Export2emf = ""
  CloseClipboard
End Function

Oskar Shon, Office System
MVP

Press if Helpful; Answer when a problem solved

• Proposed as answer by
  danishani
  Monday, February 13, 2012 12:23 AM
• Marked as answer by
  danishani
  Tuesday, February 14, 2012 12:12 AM

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

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") & "desktopimages" '"
        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

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