VBA: Excel Range copied at high resolution to power point slide

[Max2004]

Hi there,

I've found and modified a code that I use to copy a certain range in Excel (which includes some charts) and paste it into powerpoint, to be used as part of a toolbox. This works very well and is extremely useful.

However; the quality of the plots becomes quite low when I paste the range as a bitmap or picture (the only two options I can get to work).
It seems like this is a somewhat known problem (possibly related to the screen resolution), but I've yet to find a solution.

I figure that using an enhanced metafile paste or something might help, but can anyone provide any input on this? It would be EXTREMELY helpful!

The full VBA code I use is listed below.

- Martin

__________________________________________________

Public Enum PasteFormat
    xl_Link = 0
    xl_HTML = 1
    xl_Bitmap = 2
End Enum


Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
                                    ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)
    
    '   Modified version of code originally posted here:
    '       http://www.vbaexpress.com/kb/getarticle.php?kb_id=370
    
    '   Modified by     : Krishnakumar @ ExcelFox.com
    '   Used Late binding so that no issues when users have multiple Excel version
    
    Dim PasteRange      As Boolean
    Dim objChart        As ChartObject
    Dim lngSU           As Long
    Dim NewS As Object
    
    Select Case TypeName(PasteObject)
        Case "Range"
            If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
            PasteRange = True
        Case "Chart": Set objChart = PasteObject.Parent
        Case "ChartObject": Set objChart = PasteObject
        Case Else
            MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
            Exit Sub
    End Select
    
  
    With Application
        lngSU = .ScreenUpdating
        .ScreenUpdating = 0
    End With
    
    ppApp.ActiveWindow.View.GotoSlide ppSlide.SlideNumber


    On Error GoTo -1: On Error GoTo 0
    DoEvents
    
    'ppApp.ActiveWindow.ViewType = ppViewSlide
    
    If PasteRange Then
        If Paste_Type = xl_Bitmap Then
            '//Paste Range as Picture
            PasteObject.CopyPicture , Format:=xlPicture
            ppSlide.Select
            ppSlide.Shapes.Paste.Select
            
            


        ElseIf Paste_Type = xl_HTML Then
            '//Paste Range as HTML
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(8, Link:=1).Select  'ppPasteHTML
        ElseIf Paste_Type = xl_Link Then
            '//Paste Range as Linked
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(0, Link:=1).Select   'ppPasteDefault
        End If
    Else
        If Paste_Type = xl_Link Then
            '//Copy & Paste Chart Linked
            objChart.Chart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(Link:=True).Select
        Else
            '//Copy & Paste Chart Not Linked
            objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
            ppSlide.Shapes.Paste.Select
        End If
    End If
     
     
    '//Define size:
    ppApp.ActiveWindow.Selection.ShapeRange.Height = 380
    'ppApp.ActiveWindow.Selection.ShapeRange.Width =
    
    '//Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    ppApp.ActiveWindow.Selection.ShapeRange.Top = 110


    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = lngSU
    End With
    
    AppActivate ("Microsoft Excel")
    
End Sub


Sub kTest()
    Dim ppApp       As Object
    Dim ppSlide     As Object
    Dim ppSlideRange As Object
    Dim ppPres As Object
    
    
    On Error Resume Next
    Set ppApp = GetObject(, "Powerpoint.Application")
    On Error GoTo 0
    
    If ppApp Is Nothing Then
        Set ppApp = CreateObject("Powerpoint.Application")
        ppApp.Visible = True
        ppApp.presentations.Add
    End If
   
    
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
        
    Else
        'ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
       
        'Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
        Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
        
    End If
    
    Set ppPres = ppApp.ActivePresentation


    ppApp.ActiveWindow.ViewType = 1
    
    '//or you could specify the slide number. e.g. for the second slide
    'Set ppSlide = ppApp.ActivePresentation.Slides(2)
    
    'Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.ChartObjects(1).Chart, xl_Bitmap
    
    '//Range
    'Worksheets("Overblik").Select


    Copy_Paste_to_PowerPoint ppApp, ppSlide, Worksheets("Overblik (hovedkategori)"), Worksheets("Overblik (hovedkategori)").Range("B24:N61"), xl_Bitmap
    Set ppSlide = Nothing
    Set ppApp = Nothing


End Sub

 

[CharlesChuckieCharles]

Try changing your Public Enum Pasteformat entry xl_bitmap=2 to xl_bitmap= -4147

xlPicture

-4147

Drawn picture (.png, .wmf, .mix).

<tbody>
</tbody>

 

[Max2004]

I actually tried that (it was in the original code), but it still creates the "crunchy quality" look - any idea why this happens?

 

[CharlesChuckieCharles]

have you tried doing a straight copy of an excel chart and paste into Powerpoint, was that any better quality?

 

[Max2004]

Yes, so if you do it by manually copying the range, then pasting it (using paste special) in powerpoint as either Bitmap, Enhanced Metafile etc - then it is very good quality in terms of resolution (and without any odd text/color problems). But somehow the VBA macro I'm using makes this become rather crude in quality and in particular line charts become pixelated, while the text becomes almost unreadable at times.

Any input on changing the code somehow would be super appreciated! Thanks for your inputs so far!

 

[CharlesChuckieCharles]

The mistake is maybe using EXCEL parameters on the PowerPoint object?



so in the Copy_... sub


If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture , Format:=xlPicture
ppSlide.Select
ppSlide.Shapes.Paste.Select

If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture , Format:=xlPicture
ppSlide.Select
ppSlide.Shapes.Paste.Select


replace the bold line with one of the red or green ( try green first )

ppSlide.Shapes.PasteSpecial (ppPasteJPG)
ppSlide.Shapes.PasteSpecial (5)


This is the enum list of Powerpoint paste options

ppPasteBitmap 1 Paste bitmap.
ppPasteDefault 0 Paste the default content of the clipboard.
ppPasteEnhancedMetafile 2 Paste enhanced Metafile
ppPasteGIF 4 Paste a GIF image.
ppPasteHTML 8 Paste HTML.
ppPasteJPG 5 Paste a JPG image.
ppPasteMetafilePicture 3 Paste a Metafile picture.
ppPasteOLEObject 10 Paste OLE object.
ppPastePNG 6 Paste PNG image.
ppPasteRTF 9 Paste RTF.
ppPasteShape 11 Paste a shape.
ppPasteText 7 Paste text.

 

[Max2004]

@CharlesChuckieCharles
I tried to do the red (the green wouldnt work), but I get the excact same quality result by using any of the above enum options. In fact this may guide the insight on the problem; I mean, shouldn't I expect to get a different result when using ppPasteEnhancedMetafile vs ppPasteText e.g.? The range-paste looks excactly the same?

Maybe it's because I'm pasting a range, not a chart?

Any idea why the above have no effect? I also tried the xl versions, but to no avail. Maybe it is related to the moment where I copy the picture?

 

[Max2004]

If anyone has any idea on this, it would be hugely helpful it would save a lot of people a ton of time..

Thanks!

 

[erichill70]

If anyone has any idea on this, it would be hugely helpful it would save a lot of people a ton of time..

Thanks!

Hi Max,

I actually ran into this same issue. I resolved it by copying the chart directly instead of range... Looks a million times better.

XL.Sheets("CPIchart").ChartObjects("Chart 1").CopyPicture

Here is my boiler-plate code for copy/pasting charts charts from Excel to PowerPoint (note replace XL and PPT with Application object)

'** PASTE CHARTS
                XL.Sheets("SheetWithChart").ChartObjects("Chart 1").CopyPicture
                PPT.ActiveWindow.Panes(2).Activate
                PPT.ActiveWindow.View.PasteSpecial DataType:=ppPasteEnhancedMetafile
                With PPT.ActiveWindow.Selection
                    .ShapeRange.Left = 10
                    .ShapeRange.Top = 88
                    .ShapeRange.LockAspectRatio = msoTrue
                 '   .ShapeRange.Height = 429
                    .ShapeRange.Width = 694
                    .ShapeRange.ZOrder msoSendToBack
                End With

Hope this helps you out.

 

[Max2004]

THanks a lot for your answer! I actually got to the same conclusion and have been doing the chart-paste on top of the range, though it does give some "alignment" issues, where a lot of time is spent on adjusting the Top, Left, Width statements etc to fit the graph in its original place. Dunno if there is a smarter way to do this, but as you say it at least works