Solved

Amend a code to export charts

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

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 80

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

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Dealing with unintended Excel Active-X resizing quirks (VBA code simulates "self correction") David Miller (dlmille) Intro Not everyone is a fan of Active-X controls in spreadsheets (as opposed to the UserForm approach, the older Form controls …
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

706 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now