Excel to Powerpoint export

I am trying to re use the following code to transfer all my excel 2007 charts to a powerpoint presentation. The problem with the existing code was it could not transfer charts that are moved as sheet itself.
For that I have introduced a new loop to capture those charts (marked in red). I am assuming that I am not using right object.

ActiveWorkbook.Worksheet.ChartObjects

I apolosize for my last post, in which I didn't wrapped my code in tags


Please advice.

Thanks,
Webbug


Full code

Public Sub TransferToPPT()
'Excel Application objects declaration
Dim objSheet As Worksheet
Dim obj_chart As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
'Powerpoint Application objects declaration
Dim pptApp As Object 'PowerPoint.Application
Dim pptPre As Object 'PowerPoint.Presentation
Dim pptSld As Object 'PowerPoint.Slide
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
'Create a new presentation
Set pptPre = pptApp.Presentations.Add
'Loop through each worksheet
For Each objSheet In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If objSheet.ChartObjects.Count > 0 Then
'Loop through each chart object in worksheet
For Each objChartObject In objSheet.ChartObjects
'Set chart object
Set objChart = objChartObject.Chart
'Create new slide for the chart
'ppLayoutBlank = 12
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, 12)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste
End With
Next objChartObject
End If
Next objSheet

' For chart sheets
'Loop through each chart object in worksheet
For Each obj_chart In ActiveWorkbook.Worksheet.ChartObjects
'Set chart object
Set objChart = obj_chart
'Create new slide for the chart
'ppLayoutBlank = 12
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, 12)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste
End With
Next obj_chart
'Activate PowerPoint application
pptApp.Visible = True
pptApp.Activate
End Sub

I have not had time to work up an example. If you posted a sample xls, it would help us help you. Until then, this thread might be of some help. http://www.excelforum.com/excel-prog...nt-slides.html

Dear Sir,

Thank you for helping me.
I have attached an excel with some Q&D charts.

Thanks,
Webbug

Thank you.

Its is working now...

webbug

I will really appreciate if you could also suggest appropriate modification as to

if there are any active presentation available, code add charts on that, if not it will create a new one. I have tried using the following code for activating any existing ppt.

pptApp.Presentations.Activate

Set pptApp = CreateObject("PowerPoint.Application")
'Create a new presentation
Set pptPre = pptApp.Presentations.Add

Thanks for your great helps.

Webbug

Many Thanks..

Webbug..

Here is a GetObject method to add to an existing Presentation or add to a new one if not.

Public Sub TransferToPPT()
  'Excel Application objects declaration
  Dim objSheet As Worksheet
  Dim obj_chart As Worksheet
  Dim objChartObject As ChartObject
  Dim objChart As Chart
  'Powerpoint Application objects declaration
  Dim pptApp As Object 'PowerPoint.Application
  Dim pptPre As Object 'PowerPoint.Presentation
  Dim pptSld As Object 'PowerPoint.Slide
  
  'Set reference to existing Presentation IF it exists
  On Error Resume Next
  Set pptApp = GetObject(, "PowerPoint.Application")
  Set pptPre = pptApp.ActivePresentation
  If Err.Number <> 0 Then
    'Create a new Powerpoint session
    Set pptApp = CreateObject("PowerPoint.Application")
    'Create a new presentation
    Set pptPre = pptApp.Presentations.Add
  End If
  On Error GoTo 0
  
  'Loop through each worksheet
  For Each objSheet In ActiveWorkbook.Worksheets
    'Verify if there is a chart object to transfer
    If objSheet.ChartObjects.Count > 0 Then
      'Loop through each chart object in worksheet
      For Each objChartObject In objSheet.ChartObjects
        'Set chart object
        Set objChart = objChartObject.Chart
        'Create new slide for the chart
        'ppLayoutBlank = 12
        Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, 12)
        With objChart
          'Copy chart object as picture
          objChart.CopyPicture xlScreen, xlBitmap, xlScreen
          'Paste copied chart picture into new slide
          pptSld.Shapes.Paste
        End With
      Next objChartObject
    End If
  Next objSheet

    ' For chart sheets
    For Each objChart In ActiveWorkbook.Charts
        'Create new slide for the chart
        'ppLayoutBlank = 12
        Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, 12)
        'Copy chart object as picture
        objChart.CopyPicture xlScreen, xlBitmap, xlScreen
        'Paste copied chart picture into new slide
        pptSld.Shapes.Paste
    Next objChart
    
  'Activate PowerPoint application
  pptApp.Visible = True
  pptApp.Activate
End Sub