Diagramme in Powerpoint 2010 an bestimmte Stellen
02.04.2013 13:27:15
Micha
ich habe einen VBA code für das Einfügen von Diagrammen von einer geöffneten Exceldatei in eine geöffnete Powerpointdatei.
Leider bekomme ich es nur hin, dass jeweils ein Diagramm auf eine PPT-Seite exportiert wird.
Mein Anliegen ist es aber, die vorhandenen 3 Diagramme von der Excelseite auf EINE PPT-Seite an bestimmte Positionen (z.B. dia1 in das erste Viertel der PPT, dia2 in das zweite Viertel der PPt) zu exportieren.
Geht das? Hat jemand damit Erfahrung? Würde mich um Feedback freuen.
Viele Grüße Micha
Anbei mein Code
Sub Diagramme_in_PPT()
' Verweis auf Microsoft PowerPoint Object Library setzen
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
' Diagramm als Bild kopieren
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Neue Seite in geöffnete PPT einfügen und Diagramm einfügen
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart zentriert das Diagramm Code als Reserve
'PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'Eingefügtes Diagramm skalieren
With PPApp.ActiveWindow.Selection.ShapeRange
'Oberer Rand 1 cm unter Standardtitel
.Top = 140
'Linker Rand 1.5 cm von linkem Folienrand
.Left = 100
'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
.Width = 150
'Bei Bedarf Höhe noch einstellen Hier ist jedoch zu beachten, dass das _
Object skaliert wird !!!
'Die Breite verändert sich dann
.Height = 150
End With
End With
Next
'zurücksetzen
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub