M
Mats Teir
I have a macro to transfer Excel graphs into PowerPoint slides, which works
fine, but the pasted graphs (pictures) are (with original shape pasted across
teh slide. I would like them to get pasted into the "Placeholder" that is
automatically created on a new slide.
Anyone have an idea how to get this done?
Thanks in advance
Mats
Sub TransferGraphs()
'
' TransferGraphs Macro
' Transfer all graphs on selected worksheet as pictures to PPT file
'
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
Dim sTitle As String
' Create instance of PowerPoint
Set PPApp = CreateObject("Powerpoint.Application")
' For automation to work, PowerPoint must be visible
' (alternatively, other extraordinary measures must be taken)
PPApp.Visible = True
' Create a presentation
Set PPPres = PPApp.Presentations.Add
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(iCht).Chart
' get chart title
If .HasTitle Then
sTitle = .ChartTitle.Text
Else
sTitle = ""
End If
' remove title (or it will be redundant)
.HasTitle = False
' copy chart as a picture
.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' restore title
If Len(sTitle) > 0 Then
.HasTitle = True
.ChartTitle.Text = sTitle
End If
End With
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutObject)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart TO THE MIDDLE OF THE SLIDE AND INSERT THE SLIDE
TITLE (COPIED FROM THE GRAPH)
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
End With
Next
' Save and close presentation
With PPPres
.SaveAs "C:\MACROTEST\MACROTEST.ppt"
.Close
End With
' Quit PowerPoint
' PPApp.Quit
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
fine, but the pasted graphs (pictures) are (with original shape pasted across
teh slide. I would like them to get pasted into the "Placeholder" that is
automatically created on a new slide.
Anyone have an idea how to get this done?
Thanks in advance
Mats
Sub TransferGraphs()
'
' TransferGraphs Macro
' Transfer all graphs on selected worksheet as pictures to PPT file
'
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
Dim sTitle As String
' Create instance of PowerPoint
Set PPApp = CreateObject("Powerpoint.Application")
' For automation to work, PowerPoint must be visible
' (alternatively, other extraordinary measures must be taken)
PPApp.Visible = True
' Create a presentation
Set PPPres = PPApp.Presentations.Add
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(iCht).Chart
' get chart title
If .HasTitle Then
sTitle = .ChartTitle.Text
Else
sTitle = ""
End If
' remove title (or it will be redundant)
.HasTitle = False
' copy chart as a picture
.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' restore title
If Len(sTitle) > 0 Then
.HasTitle = True
.ChartTitle.Text = sTitle
End If
End With
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutObject)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart TO THE MIDDLE OF THE SLIDE AND INSERT THE SLIDE
TITLE (COPIED FROM THE GRAPH)
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
End With
Next
' Save and close presentation
With PPPres
.SaveAs "C:\MACROTEST\MACROTEST.ppt"
.Close
End With
' Quit PowerPoint
' PPApp.Quit
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub