VBA:Export Data from A Range as PNG Format

[Susanto3311]

hi all..

the below code work properly. the code from Hans..but i want to modified like this:
here this steps:
this step macro can do it:
1. first time, select your range/cell that you want export NOT your shape/picture, 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).

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

anyone help me out, greatly appreciated..
susant

[HansV]

I edited your post to change [quote]...[/quote] tags to [code]...[/code] tags.

[HansV]

Try this:

Code: Select all

Sub ExportRangeAsPNG()
    Dim wsh As Worksheet
    Dim rng As Range
    Dim fil As Variant
    Dim cho As ChartObject
    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 rng = Selection
    rng.CopyPicture
    Set cho = wsh.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    cho.Select
    ActiveChart.Paste
    ActiveChart.Export Filename:=fil, FilterName:="PNG"
    cho.Delete
End Sub

[Susanto3311]

hi hans...thank you so much!! work fine.

[Susanto3311]

Try this:

Code: Select all

Sub ExportRangeAsPNG()
    Dim wsh As Worksheet
    Dim rng As Range
    Dim fil As Variant
    Dim cho As ChartObject
    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 rng = Selection
    rng.CopyPicture
    Set cho = wsh.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    cho.Select
    ActiveChart.Paste
    ActiveChart.Export Filename:=fil, FilterName:="PNG"
    cho.Delete
End Sub

hi hans, in progress, the code not work if the column/rows is hidden --'for a reason the columns/rows is protected'
show message "run time error '1004' Application defined or object defined error.
show message errror (yellow highlight " rng.Offset(0, rng.Columns.Count).PasteSpecial"
please, how to fix it?

[HansV]

Could you attach a sample workbook (with the code) that demonstrates the problem?

[Susanto3311]

hi Hans...sorry i confuse about this..
if i use workbook that contains macro/code and protected your code (Export Range not working show message :
Set cho = wsh.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
if i use workbook not contains code, the code work fine..

for a reason i can't attach the original file that contains code & protected

[HansV]

Is the sheet protected?
Or the workbook?
Or the VBA project?

[Susanto3311]

the workbook is protected, the sheet is protected & vba protected too.
all of them are protected.

[HansV]

Try code like this. Replace "secret" with the worksheet password.

Code: Select all

Sub ExportRangeAsPNG()
    Dim wsh As Worksheet
    Dim rng As Range
    Dim fil As Variant
    Dim cho As ChartObject
    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
    wsh.Unprotect Password:="secret"
    Set rng = Selection
    rng.CopyPicture
    Set cho = wsh.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
    cho.Select
    ActiveChart.Paste
    ActiveChart.Export Filename:=fil, FilterName:="PNG"
    cho.Delete
    wsh.Protect Password:="secret"
End Sub