VBA：从Excel复制+粘贴所选图表到Powerpoint

Question

I am looking to copy and paste selected charts from Excel 2010 to Powerpoint 2010 as Microsoft Excel Chart Object formats into an active PPT slide. Ideally, I would like to be able to place these charts into specific positions on the active Powerpoint slide. I've scrounged the web but all if not most solutions are for all slides in a sheet to be pasted randomly on a PPT slide. I don't even have a code but if anyone can help, that would be awesome. Thanks!

Answer 1

Well, here's something: This is a pptGenerator-class that I wrote some time back. In my scenario I wanted to right click specific charts in a workbook, have "Copy to presentation" as an option in a custom context menu, and add subsequent charts on subsequent slides in either the same presentation, or a new one. These charts were captured in another class in order to create the context menu and have itself copied to the slide when passed to it. Below is a slightly modified and stripped version, that should help you out to fix your specific situation by editing this class.

In a Class module:

'PowerPoint Generator class - Rik Sportel
'Maintains a PowerPoint application for Excel workbook.
Private WithEvents pptApp As PowerPoint.Application
Private ppt As PowerPoint.Presentation
Private pptPresentations As Collection 'Collection to add presentations to
Private p_currentPresentation As Boolean

'Make sure you don't add slides if there is no presentation.
Public Property Get CurrentPresentation() As Boolean
    CurrentPresentation = p_currentPresentation
End Property

'Initialization
Private Sub Class_Initialize()
    p_currentPresentation = False
    Set pptApp = New PowerPoint.Application
    Set pptPresentations = New Collection
End Sub

'Termination
Private Sub Class_Terminate()
    Set pptPresentations = Nothing
    Set pptApp = Nothing
End Sub

'Creates a new Presentation in the powerpoint app, and adds it to the pptPresentations collection. Add methods later to cycle through them.
Public Sub NewPresentation()
    Set ppt = pptApp.Presentations.Add
    pptPresentations.Add ppt

    'Create presentation and use image stored within the current workbook as a background for it.
    ThisWorkbook.Worksheets("BGItems").Shapes(1).Copy 'Copy the background
    ppt.Windows(1).ViewType = ppViewSlideMaster
    ppt.Windows(1).View.Paste 'Paste the background
    ppt.Windows(1).ViewType = ppViewNormal

    p_currentPresentation = True
End Sub

'Add a slide to the presentation, place passed chart on it.
Public Sub AddSlide(chartForSlide As Chart)
    Dim nSlide As PowerPoint.Slide
    Dim nChart As PowerPoint.Shape

    'Create a new slide with the chart on it.
    Set nSlide = pptApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)

    chartForSlide.ChartArea.Copy
    nSlide.Shapes.Paste 'Paste the chart
    Set nChart = nSlide.Shapes(1)

    'Position the chart
    With nChart
        .Left = ppt.PageSetup.SlideWidth / 10
        .top = ppt.PageSetup.SlideHeight / 10
        .Width = ppt.PageSetup.SlideWidth / 100 * 80
        .Height = ppt.PageSetup.SlideHeight / 2
    End With

    Set nChart = Nothing
    Set nSlide = Nothing
End Sub

'Make sure to keep track of presentations properly if users interact with
'powerpoint in unexpected ways. Capture event and make sure the presentation object you write to will still exist.
Private Sub pptApp_PresentationClose(ByVal Pres As PowerPoint.Presentation)
    For i = pptPresentations.Count To 1 Step -1
        If pptPresentations.Item(i) Is Pres Then
            pptPresentations.Remove i
        End If
    Next i
    If Pres Is ppt Then
        Set ppt = Nothing
        p_currentPresentation = False
    End If
End Sub

In my "factory" module. a regular code module:

Public Sub GetPowerpoint()
    If pptApp Is Nothing Then Set pptApp = New pptGenerator
End Sub

How it's used:

'Pass a chart + optionally if it has to be a new presentation:
Public Sub CopyChartToPpt(tChart As Chart, Optional newPres As Boolean)
    GetPowerpoint
    If pptApp.CurrentPresentation = False Then pptApp.NewPresentation
    If newPres = True Then pptApp.NewPresentation

    pptApp.AddSlide tChart 

End Sub

So where and how you obtain the selected chart is another thing, but as long as you manage to select the Chart from the ChartObject or Slide in your workbook, and pass it as a parameter to the above, you should be abled to fix it according to your own specs.

Other than my advise would be to check the VBA reference for your powerpoint version over at MSDN.

Answer 2

So here's a solution that worked for me. The macro copy + pastes selected range or chart into the active PowerPoint slide into a certain position. This reason I wanted to do this is that each quarter/month we generate reports for our clients and this helps to reduce the time required for copying + pasting and making the deck look nice. Hope this helps anyone else who make a ton of PPTs!

'Export and position into Active Powerpoint

'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference

'Identifies selection as either range or chart
Sub ButtonToPresentation()

If TypeName(Selection) = "Range" Then
    Call RangeToPresentation
Else
    Call ChartToPresentation
End If

End Sub

Sub RangeToPresentation()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    'Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy the range as a picture
    Selection.CopyPicture Appearance:=xlScreen, _
    Format:=xlBitmap
    'Paste the range
    PPSlide.Shapes.Paste.Select

    'Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library

Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide

'Error message if chart is not selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
   'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
    'Reference active slide
    Set PPSlide = PPPres.Slides _
        (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy chart as a picture
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
        Format:=xlPicture
    'Paste chart
    PPSlide.Shapes.Paste.Select

    'Align pasted chart
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub