Meerdere grafieken naar Powerpoint

[Ernootje]

Het was mij gelukt om meerdere grafieken naar Powerpoint over te brengen.
Helaas werkt het nu niet meer en ik kan de fout niet vinden.
Er wordt maar 1 grafiek (de laatste geselcteerde) in Powerpoint getoond.
Wie weet de oplossing?

m.v.g.,
Onno.

Script:

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

Sheets("duwjaar").Select
ActiveSheet.ChartObjects("Grafiek 1").Activate
ActiveChart.ChartArea.Select
ActiveSheet.ChartObjects("Grafiek 1").Activate
ActiveChart.ChartArea.Copy
Sheets("duwwijk").Select
ActiveSheet.ChartObjects("Grafiek 1").Activate
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy
Sheets("duwdag").Select
ActiveSheet.ChartObjects("Grafiek 1").Activate
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy
Sheets("duwnomadag").Select
ActiveSheet.ChartObjects("Grafiek 1").Activate
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy
If ActiveChart Is Nothing Then
MsgBox "Selecteer een grafiek en probeer opnieuw.", vbExclamation, _
"Geen grafiek geselecteerd"
Else
' Reference instance of PowerPoint
On Error Resume Next

' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
' PowerPoint is not running, create new instance
Set PPApp = CreateObject("PowerPoint.Application")
PPApp.Visible = True
End If
On Error GoTo 0

' Reference presentation and slide
On Error Resume Next
If PPApp.Windows.Count > 0 Then
' There is at least one presentation
' Use existing presentation
Set PPPres = PPApp.ActivePresentation
' Use active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Else
' There are no presentations
' Create new presentation
Set PPPres = PPApp.Presentations.Add
' Add first slide
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
End If

On Error GoTo 0

' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewSlide

' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture

' Paste chart
PPSlide.Shapes.Paste.Select

' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

'Save presentation to desired path
With PPPres
.SaveAs "C:\Documents and Settings\User\Mijn documenten\ppt.ppt"
.Close
End With

' Quit PowerPoint
PPApp.Quit

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If



End Sub

 

[Wigi]

Hang eens een zipfile hier bij met alle bestanden die helpers nodig hebben om het te kunnen testen. Anders is het gokken voor ons en daar schieten we ook niet mee op.

 

[Ernootje]

Bestandje

Hierbij het Excelbestandje met script.

 

[Warme bakkertje]

Beste Onno,
De macro die ik je enkele dagen geleden gegeven heb is dan ook maar geschikt om 1 grafiek door te sturen. Voor meerdere grafieken ga terug naar onderstaande link en selecteer de geschikte macro, en bewerk naar eigen wens.

http://peltiertech.com/Excel/XL_PPT.html

Mvg

Rudi

 

[Ernootje]

Thnx Rudi.:thumb:
Ga 't proberen!!!

 

[Ernootje]

Thnx Rudi.:thumb:
Ga 't proberen!!!

Helaas blijft 't probleem bestaan.
Alleen de laatse grafiek komt in Powerpoint en de eerste 2 niet.

 

[Wigi]

Helaas blijft 't probleem bestaan.
Alleen de laatse grafiek komt in Powerpoint en de eerste 2 niet.

Worden die misschien net over elkaar geplakt? (ik heb de code nog niet in detail kunnen bekijken).

 

[Ernootje]

Worden die misschien net over elkaar geplakt? (ik heb de code nog niet in detail kunnen bekijken).

Nee, daar had ik al naar gekeken.
Er wordt maar 1 dia aangemaakt, i.p.v. 3.

 

[Warme bakkertje]

Onno, in bijlage uitgewerkt model meerdere grafieken.

Mvg

Rudi

 

[Ernootje]

Dat is 'm!!!!
Geweldig!!!
Bedankt!!!:thumb:

Onno