Conversion of excel chart into PPT slide using macro

[dhananjaywalke]

Hi all

I am currently using one macro to copy excel charts & paste them into the PPT slide. I am using enhanced meta format to copy the chart into the slide but now the file size is big.

Can you please help to reduce the file size may be by changing the macro or changing the copy paste format. I dont know what to do?

See the macro below for your reference

Sub PPGenerate()

'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
     
'Part of code sourced from Jon Peltier [url]http://peltiertech.com/Excel/XL_PPT.html[/url]
     
Dim SheetName As String
Dim AddSlidesToEnd As Boolean
Dim i, h As Integer
Dim cel, loc, fil As String

i = 71
Set ppApp = New PowerPoint.Application
If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add
AddSlidesToEnd = True
Do Until i = 93
cel = "Reference!A" & i
loc = Excel.Range(cel).Value
Excel.Range("Control!B7").Value = loc
Sheets("Month").Select

SheetName = ActiveSheet.Name
    
    '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
        
             '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)

    End If
     

         'Options for Copy and Paste Charts
        Sheets(SheetName).Activate
        ActiveChart.ChartArea.Select
        Call chartscale

        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        'ppSlide.Shapes.Paste.Select
        ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
 
     
     'Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
     
     
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ppApp.ActivePresentation.PrintOptions.OutputType = ppPrintOutputFourSlideHandouts
    ppApp.ActivePresentation.PageSetup.SlideOrientation = msoOrientationHorizontal
    ppApp.ActivePresentation.PageSetup.NotesOrientation = msoOrientationHorizontal
     
     
    AppActivate ("Microsoft PowerPoint")
    Set ppSlide = Nothing
     
i = i + 1
Loop

Sheets("KNA").Select
Sheets("KNA").Activate

    
    '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
        
             '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)

    End If
     

         'Options for Copy and Paste Charts
        Sheets("KNA").Activate
        ActiveChart.ChartArea.Select

        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        ppSlide.Shapes.Paste.Select


     
     'Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
     
     
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ppApp.ActivePresentation.PrintOptions.OutputType = ppPrintOutputFourSlideHandouts
    ppApp.ActivePresentation.PageSetup.SlideOrientation = msoOrientationHorizontal
    ppApp.ActivePresentation.PageSetup.NotesOrientation = msoOrientationHorizontal
     
     
    AppActivate ("Microsoft PowerPoint")
    Set ppSlide = Nothing
    
Sheets("AS").Select
Sheets("AS").Activate

    
    '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
        
             '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)

    End If
     

         'Options for Copy and Paste Charts
        Sheets("AS").Activate
        ActiveChart.ChartArea.Select

        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        ppSlide.Shapes.Paste.Select


     
     'Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
     
     
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ppApp.ActivePresentation.PrintOptions.OutputType = ppPrintOutputFourSlideHandouts
    ppApp.ActivePresentation.PageSetup.SlideOrientation = msoOrientationHorizontal
    ppApp.ActivePresentation.PageSetup.NotesOrientation = msoOrientationHorizontal
     
     
    AppActivate ("Microsoft PowerPoint")
    Set ppSlide = Nothing
    
    
Sheets("AP").Select
Sheets("AP").Activate

    
    '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
        
             '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)

    End If
     

         'Options for Copy and Paste Charts
        Sheets("AP").Activate
        ActiveChart.ChartArea.Select

        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        ppSlide.Shapes.Paste.Select


     
     'Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
     
     
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ppApp.ActivePresentation.PrintOptions.OutputType = ppPrintOutputFourSlideHandouts
    ppApp.ActivePresentation.PageSetup.SlideOrientation = msoOrientationHorizontal
    ppApp.ActivePresentation.PageSetup.NotesOrientation = msoOrientationHorizontal
     
     
    AppActivate ("Microsoft PowerPoint")
    Set ppSlide = Nothing
On Error GoTo exi
    
ppApp.ActivePresentation.SaveAs Filename
exi:
Err.Clear

ppApp.Quit

End Sub

 

[sweater_vests_rock]

dh.

could you compress the pics in PPT using the compress pictures option on the Picture toolbar?

ben.

 

[dhananjaywalke]

Compress Picture didnot work.


I need something else to help me out in this issue.

Any ways sweater_vests_rock thanks for that value addition

 

[kcchiefsae]

Does anyone know how to clear an already existing slide before pasting the chart from excel?

Thanks,

KC