VBA : Export Shape/Image/Object As Picture (.PNG Fomat)

[Susanto3311]

hi expert..

i'm looking vba code to export shape/image/object as picture (as .png format)
this step macro can do it:
1. first time, select your shape/image/object, then run macro
2. browse folder location to save...
3. save as .png format
4. the macro code working in active sheet (any name sheet).
5. the code can made as excel add-ins , please don't make/save in .xlsm format

here attachment excel file
thank in advance

.susanto

[HansV]

Here is a macro:

Code: Select all

Sub ExportAsPNG()
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim fil As Variant
    Dim cho As ChartObject
    On Error Resume Next
    Set shp = Selection.ShapeRange(1)
    On Error GoTo 0
    If shp Is Nothing Then
        MsgBox "Please select a shape/picture, then try again!", vbExclamation
        Exit Sub
    End If
    fil = Application.GetSaveAsFilename(InitialFileName:="*.png", FileFilter:="PNG files (*.png), *.png")
    If fil = False Then
        MsgBox "You didn't specify a filename!", vbExclamation
        Exit Sub
    End If
    Set wsh = ActiveSheet
    Set cho = wsh.ChartObjects.Add(Left:=shp.Left, Top:=shp.Top, Width:=shp.Width, Height:=shp.Height)
    shp.Copy
    cho.Select
    ActiveChart.Paste
    ActiveChart.Export Filename:=fil, FilterName:="PNG"
    cho.Delete
End Sub

[Susanto3311]

hi Hans,
it worked!!! Thank you very much.

[thijmen2256]

Hi,

I tried this and it only seems to work if i put the macro on 1 object.
I would love to select lets say 60 objects and export them all at once, is this possible?
The ideal thing would be if it takes the name from the cel next to it.
This is how my file looks:

[HansV]

Welcome/welkom to Eileen's Lounge!

Try this version:

Code: Select all

Sub ExportAllAsPNG()
    Dim fld As String
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim rng As Range
    Dim fil As Variant
    Dim cho As ChartObject
    ' Folder path - I used the folder of the workbook
    fld = ActiveWorkbook.Path
    If Right(fld, 1) <> Application.PathSeparator Then
        fld = fld & Application.PathSeparator
    End If
    Set wsh = ActiveSheet
    For Each shp In wsh.Shapes
        Set rng = shp.TopLeftCell
        If rng.Column = 2 Then ' column B
            fil = fld & rng.Offset(0, -1).Value & ".png"
            Set cho = wsh.ChartObjects.Add(Left:=shp.Left, Top:=shp.Top, Width:=shp.Width, Height:=shp.Height)
            shp.Copy
            cho.Select
            ActiveChart.Paste
            ActiveChart.Export Filename:=fil, FilterName:="PNG"
            cho.Delete
        End If
    Next shp
End Sub

[snb]

Adapt the export directory

Code: Select all

Sub M_snb()
   c00 = "G:\OF\"
   
   With Sheet1.ChartObjects.Add(1, 1, 100, 100).Chart
      For Each it In Sheet1.Shapes
      If it.TopLeftCell.Address <> "$A$1" Then
        it.CopyPicture
        .Paste
        .Export c00 & it.TopLeftCell.Offset(, -1) & ".png"
        .Shapes(1).Delete
        End If
      Next
      .Parent.Delete
    End With
End Sub

If you select shapes beforehand:
instead of

Code: Select all

For Each it In Sheet1.Shapes

use

Code: Select all

For Each it In Selection.Shapes

[thijmen2256]

Thanks for all the help guys,

The solution from Hans already did the trick for me.

[mpeline]

Hi Hans

I have tried your code to save all pictures as png, but I get an error when about 13 pictures has been saved.
But if I put in a wait statement (1 sec.) inside the loop then I runs without problems, do you have any idea why?

[HansV]

Welcome to Eileen's Lounge!

That's probably because there wasn't enough time between the commands without the Wait statement.
One or two lines

DoEvents

inside the loop might also work.

[mpeline]

It worked perfectly, thanks a lot

That's probably because there wasn't enough time between the commands without the Wait statement.
One or two lines

DoEvents

inside the loop might also work.

[extrapurifier]

Hello Hans,

Thank you very much! Your code was exactly what I needed to automate my workflow. But I still have a problem and unfortunately can't find a solution myself. After almost 2 hours of experimenting, I'll try to ask you if you can help me again. Your code quoted below asks you to save the image file. I think it is this line

Code: Select all

fil = Application.GetSaveAsFilename(InitialFileName:=‘*.png’, FileFilter:=‘PNG files (*.png), *.png’)

Do you have a tip on how I can also automate this step? I know the file name, the storage path and can easily overwrite existing files. I have adapted your code as follows, but can't find a way to automatically skip the save dialogue?

Code: Select all

Sub KlimaTabelleAlsBildSpeichern()
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim fil As Variant
    Dim cho As ChartObject
    ActiveSheet.Shapes.Range(Array("Klimatabelle")).Select
    On Error Resume Next
    Set shp = Selection.ShapeRange(1)
    On Error GoTo 0
    If shp Is Nothing Then
        MsgBox "Please select a shape/picture, then try again!", vbExclamation
        Exit Sub
    End If
    fil = Application.GetSaveAsFilename(InitialFileName:="Klimatabelle" & Range("B11") & ".png", FileFilter:="PNG files (*.png), *.png")
    If fil = False Then
        MsgBox "You didn't specify a filename!", vbExclamation
        Exit Sub
    End If
    Set wsh = ActiveSheet
    Set cho = wsh.ChartObjects.Add(Left:=shp.Left, Top:=[i]NotAllowedToPost[/i], Width:=shp.Width, Height:=shp.Height)
    shp.Copy
    cho.Select
    ActiveChart.Paste
    ActiveChart.Export Filename:=fil, FilterName:="PNG"
    cho.Delete
End Sub

Thank you very much!

Here is a macro:

Code: Select all

Sub ExportAsPNG()
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim fil As Variant
    Dim cho As ChartObject
    On Error Resume Next
    Set shp = Selection.ShapeRange(1)
    On Error GoTo 0
    If shp Is Nothing Then
        MsgBox "Please select a shape/picture, then try again!", vbExclamation
        Exit Sub
    End If
    fil = Application.GetSaveAsFilename(InitialFileName:="*.png", FileFilter:="PNG files (*.png), *.png")
    If fil = False Then
        MsgBox "You didn't specify a filename!", vbExclamation
        Exit Sub
    End If
    Set wsh = ActiveSheet
    Set cho = wsh.ChartObjects.Add(Left:=shp.Left, Top:=[i]NotAllowedToPost[/i], Width:=shp.Width, Height:=shp.Height)
    shp.Copy
    cho.Select
    ActiveChart.Paste
    ActiveChart.Export Filename:=fil, FilterName:="PNG"
    cho.Delete
End Sub

[HansV]

Welcome to Eileen's Lounge!

Let's say the image is C:\Folder\Subfolder\Image.png. Replace the lines

Code: Select all

    fil = Application.GetSaveAsFilename(InitialFileName:=‘*.png’, FileFilter:=‘PNG files (*.png), *.png’)
    If fil = False Then
        MsgBox "You didn't specify a filename!", vbExclamation
        Exit Sub
    End If

with the single line

Code: Select all

    fil = "C:\Folder\Subfolder\Image.png"

[extrapurifier]

Thank you Hans!
Thank you!

You made my day!

That was it!