Solved

Amend a code to export charts

Posted on 2008-10-06
5
811 Views
Last Modified: 2013-11-25
Hi Everyone,

I'm sure the following code may be familiar to some and my attempt here is to modify it in order to capture all the charts in every worksheeti in the workbook.

At the moment it only captures the chart number assigned to CHART NUMBER.   Perhaps I may be missing a step and if so, I'm hoping someone would point it out to me.  At the end of the day, here is what I ultimately am looking to do - capture every chart on every worksheet and export it as a picture to the last slide in  powerpoint.

Thank you for any assistance you can offer)

Sub Copy_Paste_to_PowerPoint() 
     
     'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
    Dim ppApp As PowerPoint.Application 
    Dim ppSlide As PowerPoint.Slide 
     
     'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html
     'This code developed at http://oldlook.experts-exchange.com:8080/Applications/MS_Office/Excel/Q_21337053.html
     
    Dim SheetName As String 
    Dim TestRange As Range 
    Dim TestSheet As Worksheet 
    Dim TestChart As ChartObject 
     
    Dim PasteChart As Boolean 
    Dim PasteChartLink As Boolean 
    Dim ChartNumber As Long 
     
    Dim PasteRange As Boolean 
    Dim RangePasteType As String 
    Dim RangeName As String 
    Dim AddSlidesToEnd As Boolean 
     
     'Parameters
     
     'SheetName           - name of sheet in Excel that contains the range or chart to copy
     
     'PasteChart          -If True then routine will  copy and paste a chart
     'PasteChartLink      -If True then Routine will paste chart with Link; if = False then paste chart no link
     'ChartNumber         -Chart Object Number
     '
     'PasteRange          - If True then Routine will copy and Paste a range
     'RangePasteType      - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
     'RangeName           - Address or name of range to copy; "B3:G9" "MyRange"
     'AddSlidesToEnd      - If True then appednd slides to end of presentation and paste.  If False then paste on current slide.
     
     'use active sheet. This can be a direct sheet name
    SheetName = ActiveSheet.Name 
     
     'Setting PasteRange to True means that Chart Option will not be used
    PasteRange = True 
    RangeName = "MyRange" 
    RangePasteType = "HTML" 
    RangeLink = True 
     
    PasteChart = True 
    PasteChartLink = True 
    ChartNumber = 1 
     
    AddSlidesToEnd = True 
     
     
     'Error testing
    On Error Resume Next 
    Set TestSheet = Sheets(SheetName) 
    Set TestRange = Sheets(SheetName).Range(RangeName) 
    Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber) 
    On Error Goto 0 
     
    If TestSheet Is Nothing Then 
        MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical 
        Exit Sub 
    End If 
     
    If PasteRange And TestRange Is Nothing Then 
        MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical 
        Exit Sub 
    End If 
     
    If PasteRange = False And PasteChart And TestChart Is Nothing Then 
        MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical 
        Exit Sub 
    End If 
     
     
     'Look for existing instance
    On Error Resume Next 
    Set ppApp = GetObject(, "PowerPoint.Application") 
    On Error Goto 0 
     
     'Create new instance if no instance exists
    If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application 
     'Add a presentation if none exists
    If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add 
     
     'Make the instance visible
    ppApp.Visible = True 
     
     'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
    If ppApp.ActivePresentation.Slides.Count = 0 Then 
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank) 
    Else 
        If AddSlidesToEnd Then 
             'Appends slides to end of presentation and makes last slide active
            ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank 
            ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count 
            Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count) 
        Else 
             'Sets current slide to active slide
            Set ppSlide = ppApp.ActiveWindow.View.Slide 
        End If 
    End If 
     
     'Options for Copy & Paste Ranges and Charts
    If PasteRange = True Then 
         'Options for Copy & Paste Ranges
        If RangePasteType = "Picture" Then 
             'Paste Range as Picture
            Worksheets(SheetName).Range(RangeName).Copy 
            ppSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select 
        Else 
             'Paste Range as HTML
            Worksheets(SheetName).Range(RangeName).Copy 
            ppSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select 
        End If 
    Else 
         'Options for Copy and Paste Charts
        Worksheets(SheetName).Activate 
        ActiveSheet.ChartObjects(ChartNumber).Select 
        If PasteChartLink = True Then 
             'Copy & Paste Chart Linked
            ActiveChart.ChartArea.Copy 
            ppSlide.Shapes.PasteSpecial(link:=True).Select 
        Else 
             'Copy & Paste Chart Not Linked
            ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture 
            ppSlide.Shapes.Paste.Select 
        End If 
    End If 
     
     'Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 
     
    AppActivate ("Microsoft PowerPoint") 
    Set ppSlide = Nothing 
    Set ppApp = Nothing 
     
End Sub

Open in new window

0
Comment
Question by:JadeCaridad
  • 3
  • 2
5 Comments
 
LVL 81

Expert Comment

by:byundt
ID: 22656619
There is surely a more efficient way of working with PowerPoint objects, but the following Excel 2003 code does copy all charts onto new slides in PowerPoint 2003. It does not require you to set a reference to PowerPoint.
Sub Copy_Paste_to_PowerPoint()
     'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html
     'This code developed at http://oldlook.experts-exchange.com:8080/Applications/MS_Office/Excel/Q_21337053.html
    Dim ppApp As Object
    Dim cht As ChartObject
    Dim ws As Worksheet
    Dim i As Integer
    Dim pasteChartLink As Boolean
     
    pasteChartLink = False
    
    'Look for existing instance
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
     
     'Create new instance if no instance exists
    If ppApp Is Nothing Then Set ppApp = CreateObject("Powerpoint.Application")
     'Add a presentation if none exists
    If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add
     
     'Make the instance visible
    ppApp.Visible = True
     
     'Add a blank slide
    i = ppApp.ActivePresentation.Slides.Count
     
    For Each ws In ActiveWorkbook.Worksheets
        If ws.ChartObjects.Count > 0 Then
            For Each cht In ws.ChartObjects
                i = i + 1
                With ppApp.ActivePresentation.Slides.Add(i, 12)    'ppLayoutBlank is 12
                    .Select
                    'Options for Copy and Paste Charts
                    If pasteChartLink = True Then
                         'Copy & Paste Chart Linked
                        cht.ChartArea.Copy
                        .Shapes.PasteSpecial(link:=True).Select
                    Else
                         'Copy & Paste Chart Not Linked
                        cht.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                        .Shapes.Paste.Select
                    End If
                     'Center pasted object in the slide
                    ppApp.ActiveWindow.Selection.ShapeRange.Align 1, True       'msoAlignCenter is 1
                    ppApp.ActiveWindow.Selection.ShapeRange.Align 4, True       'msoAlignMiddles is 4
                End With
            Next
             
        End If
    Next
     
    AppActivate ("Microsoft PowerPoint")
    Set ppApp = Nothing
     
End Sub

Open in new window

0
 

Author Comment

by:JadeCaridad
ID: 22660811
I have a quick question....
Instead of opening a blank ppt doc...can I load a template and have it copy the charts there?

Something like....
  If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Open "c:\mydocs\template.pot"

Here's the problem I'm facing:
When I use  ( If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Open "c:\mydocs\template.pot")
 I get a run-time error "Presentations.Open: Invalid request.  The Powerpoint Frame Window does not exist.

If I don't instruct it to open a template the code works perfectly.  Any insight will be greatly appreciated.
0
 

Author Comment

by:JadeCaridad
ID: 22660987
another note:

when I do something like this:
 If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
         'Make the instance visible
    ppApp.Visible = True
     'Add a presentation if none exists
   If ppApp.Presentations.count = 0 Then
   ppApp.Presentations.Open ("c:\mydocs\template.pot")"
   End If

The error I get falls on this line...
  ppslide.Shapes.Paste.Select
It says:  Run-time error (80048240) :  Shape (unknown member): Invalid request.  To select a shape, its view must be active.

Again, any insight would be great as to why I'm getting these error messages.  

0
 
LVL 81

Accepted Solution

by:
byundt earned 500 total points
ID: 22661007
JadeCaridad,
As written, the macro already does what you requested. Just open PowerPoint and load the desired presentation before running the macro. The charts will be appended as new slides at the end.

Brad
0
 

Author Comment

by:JadeCaridad
ID: 22662090
Hi Brad,

Thank you for all your assistance.

All the best,
J
0

Featured Post

Secure Your Active Directory - April 20, 2017

Active Directory plays a critical role in your company’s IT infrastructure and keeping it secure in today’s hacker-infested world is a must.
Microsoft published 300+ pages of guidance, but who has the time, money, and resources to implement? Register now to find an easier way.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

713 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question