Copy Excel Chart to PowerPoint using VBA

[KevinYC]

Hello Everyone,

I am a new vba user. I am trying to copy an Excel chart into a powerpoint slide using vba. I got an error (Invalid porcedure call or argument) at this line of code "ActiveSheet.ChartObjects(chart_name).Activate" highlited in red. The code opens the powerpoint doc successfully but stops at the line colored in red. The chart's title in excel is 'income' and that's how I reference it in the fuction. What am I doing wrong?

Any input would be greatly appreciated!!

Here is my code:

Sub makePowerPoint()
...Dim PPT As PowerPoint.Application
Set PPT = New PowerPoint.Application
PPT.Visible = True
PPT.Presentations.Open Filename:="C:\My Documents\MacroTest.ppt"
Copy_chart "Sheet1", "income", 1, 250, 200, 60, 15
End Sub



Public Function copy_chart(sheet, chart_name, slide, awidth, aheight, atop, aleft)
Sheets(sheet).Select
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
PPApp.ActiveWindow.View.GotoSlide (slide)
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
ActiveSheet.ChartObjects(chart_name).Activate
ActiveChart.ChartArea.Copy
PPSlide.Select
PPSlide.Shapes.PasteSpecial ppPastePNG
PPSlide.Select
PPSlide.Shapes(PPSlide.Shapes.Count).Select
Dim sr As PowerPoint.ShapeRange
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
' Resize:
sr.Width = awidth
sr.Height = aheight
If sr.Width > 700 Then
sr.Width = 700
End If
If sr.Height > 420 Then
sr.Height = 420
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
sr.Top = atop
If aleft <> 0 Then
sr.Left = aleft
End If
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Function

 

[KevinYC]

Hi,
Does anyone have any suggestins?

Thank you!

 

[Jon Peltier]

Are you copying a chart that's embedded in a worksheet, or a chart that stands alone on its own chart sheet? This code was written for embedded charts. Is the chart object name exactly as you're passing to the procedure? No trailing blank? Does the chart actually exist on the worksheet?

There's generally no need to activate or select objects before dealing with them in VBA. You can get rid of
Sheets(sheet).Select

and replace
ActiveSheet.ChartObjects(chart_name).Activate
ActiveChart.ChartArea.Copy

with
Sheets(sheet).ChartObjects(chart_name).Chart.ChartArea.Copy

I don't think this is your problem, but if there's an issue with activating or selecting one of the objects (like a hidden sheet or a protected chart), this could be causing problems.

 

[KevinYC]

Jon,

Thank you for your input. The chart is embedded in a worksheet. The worksheet is named 'Sheet1'. It has a few rows and columns of income data. The chart is based on these data. The chart exists in the worksheet. Should the chart title = the chartObject (chart_name)? If not, what should it be?

Thanks again for your info!!

 

[Jon Peltier]

The chart title is whatever it's been set to. I doubt you want the chart title to be the same as the chart object's name.

I provided code here that copies each chart object on a worksheet to its own PowerPoint slide, using the chart title as the slide title:

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

Your code deviates from what I've posted, and I can't read your code easily enough to see if the deviation might cause a problem. You should use code tags ("code" and "/code" enclosed in square brackets) to maintain a more readable format (indentation, etc.).

 

[KevinYC]

Thank you Jon.

I commented out the line that caused the error "ActiveSheet.ChartObjects(chart_name).Activate" and the code ran fine as long as I 'click' on the chart in the worksheet first. But I have multiple charts embedded in the worksheet and I would like to copy all of the charts to PowerPoint. How can I copy them without having to mannually click on each chart before running the code.. Any suggestions?

Thank you again!!

 

[Jon Peltier]

Did you refer to the page I cited? The routine loops through all the charts in a worksheet, and does not require any clicking.

 

[KevinYC]

Thanks Jon.

I tried to run your code but had this error "user-defined type not defined" at line Function CopyCharttoPowerPoint(PPtApp As PowerPoint.Application, myChart As ChartObjects)

I tried my best to debug the code to no avail. Sorry for so many quetions and thanks for your continuous input and help!!

 

[KevinYC]

Here is the code:


Sub CopyChartsIntoPowerPoint()
''' COPY SELECTED EXCEL CHARTS INTO POWERPOINT
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPtApp As PowerPoint.Application
Dim iShapeIx As Integer, iShapeCt As Integer
Dim myShape As Shape, myChart As ChartObjects
Dim bCopied As Boolean
Set PPtApp = GetObject(, "PowerPoint.Application")
If ActiveChart Is Nothing Then
''' SELECTION IS NOT A SINGLE CHART
On Error Resume Next
iShapeCt = Selection.ShapeRange.Count
If Err Then
MsgBox "Select charts and try again", vbCritical, "Nothing Selected"
Exit Sub
End If
On Error GoTo 0
For Each myShape In Selection.ShapeRange
''' IS SHAPE A CHART?
On Error Resume Next
Set myChart = ActiveSheet.ChartObjects(myShape.Name)
If Not Err Then
bCopied = CopyCharttoPowerPoint(PPtApp, myChart)
End If
On Error GoTo 0
Next
Else
''' CHART ELEMENT OR SINGLE CHART IS SELECTED
Set myChart = ActiveChart.Parent
bCopied = CopyCharttoPowerPoint(PPtApp, myChart)
End If
Dim myPptShape As PowerPoint.Shape
Dim myScale As Single
Dim iShapesCt As Integer
''' BAIL OUT IF NO PICTURES ON SLIDE
On Error Resume Next
iShapesCt = PPtApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If Err Then
MsgBox "There are no shapes on the active slide", vbCritical, "No Shapes"
Exit Sub
End If
On Error GoTo 0
''' ASK USER FOR SCALING FACTOR
myScale = InputBox(Prompt:="Enter a scaling factor for the shapes (percent)", _
Title:="Enter Scaling Percentage") / 100
''' LOOP THROUGH SHAPES AND RESCALE "PICTURES"
For Each myPptShape In PPtApp.ActiveWindow.Selection.SlideRange.Shapes
If myPptShape.Name Like "Picture*" Then
With myPptShape
.ScaleWidth myScale, msoTrue, msoScaleFromMiddle
.ScaleHeight myScale, msoTrue, msoScaleFromMiddle
End With
End If
Next
Set myChart = Nothing
Set myShape = Nothing
Set myPptShape = Nothing
Set PPtApp = Nothing
End Sub


Function CopyCharttoPowerPoint(PPtApp As PowerPoint.Application, myChart As ChartObjects)
CopyCharttoPowerPoint = False
Chart.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen
PPtApp.ActiveWindow.View.Paste
CopyCharttoPowerPoint = True
End Function

 

[KevinYC]

Jon,

Please ignore the previous 2 posts. I actually ran the code listed below. It ran without errors and it copied each chart to a new slide. Can I copy all charts from Sheet1 to the same slide in PowerPoint? I tried playing with your code but no success..

Thank you for your help and patience...



Sub ChartsToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library

Dim PPT As PowerPoint.Application
' 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
' copy chart as a picture
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Add a new slide and paste in the chart

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
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub