Charts Sheets to Powerpoint
 

I am using some code I got from a friend and it only appears to work
for embedded chart objects? I would like it to work for Charts that
are in the Chart Sheet format.

Any Suggestions?

Thanks!

Sub Charts_To_Presentation()

'''''''''''''''''''''''''''''''''''''''''''''''''' '''
' This macro copies each chart in Excel and pastes it
' as a picture in PowerPoint
'''''''''''''''''''''''''''''''''''''''''''''''''' '''

Dim oPowerPoint As New PowerPoint.Application
Dim appPPT As PowerPoint.Application
Dim pptPres As Presentation
Dim pptSlide As Slide
Dim appXL As Excel.Application
Dim ws As Worksheet
Dim ch As Chart
Dim aChtObj As ChartObject
Dim wkb As Workbook
Dim SlideCount As Long
Dim CurrentSheetName As String


''''''''''''''''''''''''''''''''''''''''''''''''''
' Creates a new Presentation and adds title slide
''''''''''''''''''''''''''''''''''''''''''''''''''

'Set pptPres = oPowerPoint.Presentations.Add

'With pptPres.Slides
' Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
' pptSlide.Shapes.Title.TextFrame.TextRange.Text = "XXX Survey"
'End With

''''''''''''''''''''''''''''''''''''''''''''
' Reference existing instance of PowerPoint
''''''''''''''''''''''''''''''''''''''''''''

Set appPPT = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set pptPres = appPPT.ActivePresentation
appPPT.ActiveWindow.ViewType = ppViewSlide

'''''''''''''''''''''''''''''''''''''''
'Places each embedded chart in a slide
'''''''''''''''''''''''''''''''''''''''

For Each ws In ActiveWorkbook.Worksheets
CurrentSheetName = ws.Name
For Each aChtObj In ws.ChartObjects

''''''''''''''''''''''''
'copies chart
''''''''''''''''''''''''

aChtObj.Copy

''''''''''''''''''''''''''''''''''''''
'Adds a new slide and pastes the chart
''''''''''''''''''''''''''''''''''''''

SlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
appPPT.ActiveWindow.View.GotoSlide pptSlide.SlideIndex

pptSlide.Shapes.PasteSpecial(ppPasteMetafilePictur e).Select
'centers the chart
appPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters,
msoTrue
appPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles,
msoTrue



'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''
' Creates a text box and pastes the Excel sheet's name in it
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''

appPPT.ActiveWindow.Selection.SlideRange.Shapes.Ad dTextbox(msoTextOrientationHorizontal,
5, 10, 625, 27).Select
appPPT.ActiveWindow.Selection.TextRange.ParagraphF ormat.Alignment =
ppAlignLeft
appPPT.ActiveWindow.Selection.ShapeRange.TextFrame .TextRange.Characters(Start:=1,
Length:=0).Select
With appPPT.ActiveWindow.Selection.TextRange

.Text = CurrentSheetName
With .Font
.Name = "Arial"
.Size = 28
.Bold = msoFalse
End With
End With

'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''
' Creates a text box for the take-away
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''

appPPT.ActiveWindow.Selection.SlideRange.Shapes.Ad dTextbox(msoTextOrientationHorizontal,
38, 67, 652, 27).Select
appPPT.ActiveWindow.Selection.ShapeRange.TextFrame .TextRange.Paragraphs(Start:=1,
Length:=1).ParagraphFormat.Bullet.Visible = msoFalse
appPPT.ActiveWindow.Selection.TextRange.ParagraphF ormat.Alignment =
ppAlignLeft
appPPT.ActiveWindow.Selection.ShapeRange.TextFrame .TextRange.Characters(Start:=1,
Length:=0).Select
With appPPT.ActiveWindow.Selection.TextRange

.Text = "XXX"
With .Font
.Name = "Arial"
.Size = 20
.Bold = msoTrue
.Color.RGB = RGB(Red:=26, Green:=117, Blue:=206)
End With
End With

Next aChtObj
Next ws

End Sub

Charts Sheets to Powerpoint
 

Maybe this site can give some help:

http://office.microsoft.com/en-us/po...045551033.aspx

"kimbobo" wrote:

I am using some code I got from a friend and it only appears to work
for embedded chart objects? I would like it to work for Charts that
are in the Chart Sheet format.

Any Suggestions?

Thanks!

Sub Charts_To_Presentation()

'''''''''''''''''''''''''''''''''''''''''''''''''' '''
' This macro copies each chart in Excel and pastes it
' as a picture in PowerPoint
'''''''''''''''''''''''''''''''''''''''''''''''''' '''

Dim oPowerPoint As New PowerPoint.Application
Dim appPPT As PowerPoint.Application
Dim pptPres As Presentation
Dim pptSlide As Slide
Dim appXL As Excel.Application
Dim ws As Worksheet
Dim ch As Chart
Dim aChtObj As ChartObject
Dim wkb As Workbook
Dim SlideCount As Long
Dim CurrentSheetName As String


''''''''''''''''''''''''''''''''''''''''''''''''''
' Creates a new Presentation and adds title slide
''''''''''''''''''''''''''''''''''''''''''''''''''

'Set pptPres = oPowerPoint.Presentations.Add

'With pptPres.Slides
' Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
' pptSlide.Shapes.Title.TextFrame.TextRange.Text = "XXX Survey"
'End With

''''''''''''''''''''''''''''''''''''''''''''
' Reference existing instance of PowerPoint
''''''''''''''''''''''''''''''''''''''''''''

Set appPPT = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set pptPres = appPPT.ActivePresentation
appPPT.ActiveWindow.ViewType = ppViewSlide

'''''''''''''''''''''''''''''''''''''''
'Places each embedded chart in a slide
'''''''''''''''''''''''''''''''''''''''

For Each ws In ActiveWorkbook.Worksheets
CurrentSheetName = ws.Name
For Each aChtObj In ws.ChartObjects

''''''''''''''''''''''''
'copies chart
''''''''''''''''''''''''

aChtObj.Copy

''''''''''''''''''''''''''''''''''''''
'Adds a new slide and pastes the chart
''''''''''''''''''''''''''''''''''''''

SlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
appPPT.ActiveWindow.View.GotoSlide pptSlide.SlideIndex

pptSlide.Shapes.PasteSpecial(ppPasteMetafilePictur e).Select
'centers the chart
appPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters,
msoTrue
appPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles,
msoTrue



'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''
' Creates a text box and pastes the Excel sheet's name in it
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''

appPPT.ActiveWindow.Selection.SlideRange.Shapes.Ad dTextbox(msoTextOrientationHorizontal,
5, 10, 625, 27).Select
appPPT.ActiveWindow.Selection.TextRange.ParagraphF ormat.Alignment =
ppAlignLeft
appPPT.ActiveWindow.Selection.ShapeRange.TextFrame .TextRange.Characters(Start:=1,
Length:=0).Select
With appPPT.ActiveWindow.Selection.TextRange

.Text = CurrentSheetName
With .Font
.Name = "Arial"
.Size = 28
.Bold = msoFalse
End With
End With

'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''
' Creates a text box for the take-away
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''

appPPT.ActiveWindow.Selection.SlideRange.Shapes.Ad dTextbox(msoTextOrientationHorizontal,
38, 67, 652, 27).Select
appPPT.ActiveWindow.Selection.ShapeRange.TextFrame .TextRange.Paragraphs(Start:=1,
Length:=1).ParagraphFormat.Bullet.Visible = msoFalse
appPPT.ActiveWindow.Selection.TextRange.ParagraphF ormat.Alignment =
ppAlignLeft
appPPT.ActiveWindow.Selection.ShapeRange.TextFrame .TextRange.Characters(Start:=1,
Length:=0).Select
With appPPT.ActiveWindow.Selection.TextRange

.Text = "XXX"
With .Font
.Name = "Arial"
.Size = 20
.Bold = msoTrue
.Color.RGB = RGB(Red:=26, Green:=117, Blue:=206)
End With
End With

Next aChtObj
Next ws

End Sub