Sub ChartsAndTitlesToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim varPresentationFileName As Variant
Dim lngSlideCount As Long
Dim intChartCounter As Integer
Dim strChartTitle As String
' Reference existing instance of PowerPoint
On Error GoTo Fehler
Set pptApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set pptPresentation = pptApp.ActivePresentation
pptApp.ActiveWindow.ViewType = ppViewSlide
For intChartCounter = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(intChartCounter).Chart
' get chart title
If .HasTitle Then
strChartTitle = .ChartTitle.Text
Else
strChartTitle = ""
End If
' copy chart as a picture
.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
End With
' Add a new slide and paste in the chart
lngSlideCount = pptPresentation.Slides.Count
Set pptSlide = pptPresentation.Slides.Add(lngSlideCount + 1, ppLayoutTitleOnly)
pptApp.ActiveWindow.View.GotoSlide pptSlide.SlideIndex
With pptSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
.Shapes.Placeholders(1).TextFrame.TextRange.Text = strChartTitle
End With
Next
' Clean up
Set pptSlide = Nothing
Set pptPresentation = Nothing
Set pptApp = Nothing
Exit Sub
Fehler:
MsgBox "keine geöffnete PPT-Instanz gefunden. Abbruch"
End Sub