Solved

Amend a code to export charts

Posted on 2008-10-06
5
807 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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
VBA modules import 4 57
SSRS Deployment problem 5 66
Problem with a moving column in Excel 6 41
Stop display of alerts in Word via Excel 12 21
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

860 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