VBA copy charts appearance to .png

[EileenJohn]

Hi, anyone know how to copy charts appearance and save it as chart title? For example in workbook A , I have sheets1, chart title Factory5. And I want to save it as Factory5.png.
Code:
Sub CopyChart()
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Factory5").Range("A1:Q21")
Set ShTemp = Worksheets.Add
DoEvents
Charts.Add
Application.DisplayAlerts = False
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
DoEvents
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 540
.Height = PicTemp.Height + 310
End With
ChTemp.Export Filename:="D:\Charts\Factory5.png", FilterName:="png"
ShTemp.Delete
Application.ScreenUpdating = True
End Sub
The code above only set for 1 sheets. What if I want to apply it to workbook? For example: In WorkbookA, sheets1 and sheets4.

 

[ParamRay]

This code will export all the charts in your workbook:

Public Sub ExportCharts()
  Dim chtobj As ChartObject
  Dim sht As Object
  
  For Each sht In ThisWorkbook.Sheets
    If TypeOf sht Is Chart Then
      Call ExportChart(sht)
    ElseIf TypeOf sht Is Worksheet Then
      For Each chtobj In sht.ChartObjects
        Call ExportChart(chtobj.Chart)
      Next chtobj
    End If
  Next sht
  
  Shell "C:\Windows\explorer.exe " & ThisWorkbook.Path, vbNormalFocus
End Sub


Private Sub ExportChart(ByVal cht As Chart)
  cht.Export ThisWorkbook.Path & "\" & cht.ChartTitle.Text & ".png"
End Sub

 

[EileenJohn]

This code will export all the charts in your workbook:

Public Sub ExportCharts()
  Dim chtobj As ChartObject
  Dim sht As Object
  
  For Each sht In ThisWorkbook.Sheets
    If TypeOf sht Is Chart Then
      Call ExportChart(sht)
    ElseIf TypeOf sht Is Worksheet Then
      For Each chtobj In sht.ChartObjects
        Call ExportChart(chtobj.Chart)
      Next chtobj
    End If
  Next sht
  
  Shell "C:\Windows\explorer.exe " & ThisWorkbook.Path, vbNormalFocus
End Sub


Private Sub ExportChart(ByVal cht As Chart)
  cht.Export ThisWorkbook.Path & "\" & cht.ChartTitle.Text & ".png"
End Sub

Thanks gpeacock. But I want to resize my charts, where should I put this code?
DoEvents
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 540
.Height = PicTemp.Height + 310
End With
ChTemp.Export

 

[ParamRay]

If you want to resize the charts as well, use the following code instead:

Public Sub ExportCharts()
  Dim chtobj As Excel.ChartObject
  Dim intCharts As Integer
  Dim sht As Object
  
  For Each sht In ThisWorkbook.Sheets
    If TypeOf sht Is Chart Then
      Call ExportChart(sht, True)
      intCharts = intCharts + 1
    ElseIf TypeOf sht Is Worksheet Then
      For Each chtobj In sht.ChartObjects
        Call ExportChart(chtobj.Chart)
        intCharts = intCharts + 1
      Next chtobj
    End If
  Next sht
  
  If intCharts > 0 Then
    Shell "C:\Windows\explorer.exe " & ThisWorkbook.Path, vbNormalFocus
  Else
    MsgBox "No charts were found.", vbExclamation, "Export Charts"
  End If
End Sub

Private Sub ExportChart(cht As Chart, Optional ByVal blnChartSheet As Boolean = False)
  If Not blnChartSheet Then
    cht.Parent.Width = 384  ' Set dimensions
    cht.Parent.Height = 180 ' as required
  End If
  
  cht.Export ThisWorkbook.Path & "\" & cht.ChartTitle.Text & ".png"
End Sub

 

[EileenJohn]

If you want to resize the charts as well, use the following code instead:

Public Sub ExportCharts()
  Dim chtobj As Excel.ChartObject
  Dim intCharts As Integer
  Dim sht As Object
  
  For Each sht In ThisWorkbook.Sheets
    If TypeOf sht Is Chart Then
      Call ExportChart(sht, True)
      intCharts = intCharts + 1
    ElseIf TypeOf sht Is Worksheet Then
      For Each chtobj In sht.ChartObjects
        Call ExportChart(chtobj.Chart)
        intCharts = intCharts + 1
      Next chtobj
    End If
  Next sht
  
  If intCharts > 0 Then
    Shell "C:\Windows\explorer.exe " & ThisWorkbook.Path, vbNormalFocus
  Else
    MsgBox "No charts were found.", vbExclamation, "Export Charts"
  End If
End Sub

Private Sub ExportChart(cht As Chart, Optional ByVal blnChartSheet As Boolean = False)
  If Not blnChartSheet Then
    cht.Parent.Width = 384  ' Set dimensions
    cht.Parent.Height = 180 ' as required
  End If
  
  cht.Export ThisWorkbook.Path & "\" & cht.ChartTitle.Text & ".png"
End Sub

Thanks gpeacock