I am using the Peltier VBA to copy a chart from Excel to a power point chart.
I can get it to work with the exception of the pasting of the chart on the ppt slide. It will patse the chart picture then quit the function. I am at a lost for why it happens. Here is the code as I am using it. The line item in red is where it is quiting.
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
'delete old picture
PPSlide.Shapes(PPSlide.Shapes.Count).Select
PPSlide.Shapes(PPSlide.Shapes.Count).Delete
PPSlide.Select
PPSlide.Shapes.PasteSpecial ppPasteMetafilePicture
PPSlide.Select
PPSlide.Shapes(PPSlide.Shapes.Count).Select
Dim sr As PowerPoint.ShapeRange
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
' Resize:
sr.Width = (awidth * 95)
sr.Height = (aheight * 84)
If sr.Width > 800 Then
sr.Width = 800
End If
If sr.Height > 421 Then
sr.Height = 421
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
sr.Top = (atop * 84)
If aleft <> 0 Then
sr.Left = (aleft * 84)
End If
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Function
I can get it to work with the exception of the pasting of the chart on the ppt slide. It will patse the chart picture then quit the function. I am at a lost for why it happens. Here is the code as I am using it. The line item in red is where it is quiting.
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
'delete old picture
PPSlide.Shapes(PPSlide.Shapes.Count).Select
PPSlide.Shapes(PPSlide.Shapes.Count).Delete
PPSlide.Select
PPSlide.Shapes.PasteSpecial ppPasteMetafilePicture
PPSlide.Select
PPSlide.Shapes(PPSlide.Shapes.Count).Select
Dim sr As PowerPoint.ShapeRange
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
' Resize:
sr.Width = (awidth * 95)
sr.Height = (aheight * 84)
If sr.Width > 800 Then
sr.Width = 800
End If
If sr.Height > 421 Then
sr.Height = 421
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
sr.Top = (atop * 84)
If aleft <> 0 Then
sr.Left = (aleft * 84)
End If
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Function