Saving a picture to a file using VBA

[sverra]

Saving a picture to a file



I have a small macro that loops round a large dataset and generates graphs, and saves them to “PNG” files. This works perfectly. See Sub graphs_to_files

What I need to do now is save multiple graphs copy and paste as a picture, then save that picture. The code under Sub save_picture works upto the last line.



HELP PLEASE



Sub graphs_to_file()

' Set up filename

Dim MyChartName As String
MyChartName = Range("D1") & ".png"

ActiveSheet.ChartObjects("Chart 6").Activate
ActiveChart.Export MyChartName
End Sub


Sub save_picture()
' Set up filename
Dim MyPictureName As String

MyPictureName = Range("D1") & ".png"
ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 3", "Chart 2", "Chart 4", _
"Chart 5", "Chart 6", "Chart 7")).Select

Selection.Copy
Range("K56").Select
ActiveSheet.Pictures.Paste

ActiveSheet.Shapes.Range(Array("Picture 8")).Select
ActiveSheet.Shapes.Export MyChartName

End Sub

 

[Domenic]

The procedure save_picture will first temporarily group the desired charts, then it passes the grouped charts and export filename to the procedure export_charts_shape, which creates a temporary chartobject for exporting the image.

Option Explicit

Sub save_picture()

    ' Set up filename
    Dim MyPictureName As String
    MyPictureName = Range("D1") & ".png"
    
    ' Temporarily group the charts
    Dim MyChartsShape As Shape
    Set MyChartsShape = ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 3", "Chart 2", "Chart 4", "Chart 5", "Chart 6", "Chart 7")).Group
    
    ' Call sub to export the grouped charts
    export_charts_shape MyChartsShape, MyPictureName
    
    ' Ungroup the charts
    MyChartsShape.Ungroup

End Sub

Sub export_charts_shape(ByVal ChartsShape As Shape, ByVal PictureName As String)

    ' create temporary chartobject for exporting ChartsShape
    With ActiveSheet.ChartObjects.Add(Left:=ChartsShape.Left, Top:=ChartsShape.Top, Width:=ChartsShape.Width, Height:=ChartsShape.Height)
        .Activate 'needed to prevent blank exported image files
        .Border.LineStyle = 0
        ChartsShape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        With .Chart
            .Paste
            .Export Filename:=PictureName, FilterName:="png"
        End With
        .Delete
    End With
    
End Sub

Hope this helps!