VBA code to copy pictures from a workbook into a blank Powerpoint?

ajjava · Dec 19, 2018

...bit of the code, but not all of it. The excel file contains what appear to be charts, but they're really pictures. I want a macro to copy any picture on a visible worksheet into a PPT presentation. I have the code worked out to create a new, blank PPT and it does work to copy a few of the images to the PPT, but then it falls apart during the For Each section. I know enough to be dangerous but certainly am no expert. So, to recap:

* Start in excel workbook
* For each picture, on each visible worksheet, copy the picture and...
* Create a new powerpoint presentation
* Insert a new slide
* Paste each picture from the workbook onto a new slide
* Adjust the slide size/position

Here is my existing code (pieced together from various sources). Chart-specific lines have been commented out, since I'm not really working with charts (charts have been pasted into excel as pictures, via SAP/Biz Objects):

Code:

Public Sub TestCopyPastePic()
'Declare the needed variables
    Dim newPP As PowerPoint.Application
    Dim currentSlide As PowerPoint.Slide
    Dim XShape As Excel.Shape
    Dim ws As Worksheet
 'Check if PowerPoint is active
    On Error Resume Next
    Set newPP = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
'Open PowerPoint if not active
    If newPP Is Nothing Then
        Set newPP = New PowerPoint.Application
    End If
'Create new presentation in PowerPoint
    If newPP.Presentations.Count = 0 Then
        newPP.Presentations.Add
    End If
'Display the PowerPoint presentation
    'newPowerPoint.Visible = True

'Locate Excel charts to paste into the new PowerPoint presentation
    
    For Each ws In ActiveWorkbook.Worksheets
    
        If ws.Visible Then
            For Each XShape In ActiveSheet.Shapes
            'Add a new slide in PowerPoint for each Excel chart
                newPP.ActivePresentation.Slides.Add newPP.ActivePresentation.Slides.Count + 1, ppLayoutText
                newPP.ActiveWindow.View.GotoSlide newPP.ActivePresentation.Slides.Count
                Set currentSlide = newPP.ActivePresentation.Slides(newPP.ActivePresentation.Slides.Count)
    
            'Copy each Excel chart and paste it into PowerPoint as an Metafile image
                XShape.Select
                Selection.Copy
                currentSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
            'Copy and paste chart title as the slide title in PowerPoint
           ' currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
    
            'Adjust the slide position for each chart slide in PowerPoint. Note that you can adjust the values to position the chart on the slide to your liking
                newPP.ActiveWindow.Selection.ShapeRange.Left = 25
                newPP.ActiveWindow.Selection.ShapeRange.Top = 150
                currentSlide.Shapes(2).Width = 250
                currentSlide.Shapes(2).Left = 500
            Next XShape
          Else
          'Next ws
          End If
    Next ws
AppActivate ("Microsoft PowerPoint")
Set currentSlide = Nothing
Set newPP = Nothing
End Sub

areed1192 · Dec 26, 2018

Re: VBA code to copy each picture from this workbook into a blank Powerpoint? I have a little...

I rewrote some of the code to make it a little more concise. First thing I did was create some more variables to house all the different PowerPoint objects, this allows us to write the code more precisely and ensure that we are able to work that particular object.

I would take a look at the actual portion where we create an instance of PowerPoint, when I was reading your post it sounds like you are wanting a create a new PowerPoint presentation. The way the code was written you were first testing if PowerPoint was opening and then if it was you were creating the presentation. If we don't assume it's open we can technically make it work with fewer lines, but I left it the way you had it.

From there we loop through each VISIBLE worksheet, then all the shapes on that worksheet. I added a section that tests whether the shape is of the Type picture and if it is then it will copy it, otherwise, it will move on to the next shape.

Then we add a new slide, go to that slide, copy the chart, and paste it on the current slide we have selected.

Then we create a reference to the shape we just pasted, select it and then set the dimensions of that shape.

If you would like to learn more about pasting objects because there are many different ways to paste in VBA I encourage you to watch some of my YouTube Videos. Full Disclosure these are my personal YouTube videos on my channel.

Pasting Charts From Excel To PowerPoint
https://youtu.be/DOaBtYMCCEM

Pasting Shapes in PowerPoint From Excel
https://youtu.be/cpwHL26Nxhc

Manipulating Shapes in PowerPoint
https://youtu.be/TyZ47qI0NkQ

Code:

Public Sub TestCopyPastePic()

'Declare PowerPoint Variables
Dim PPTApp As PowerPoint.Application
Dim PPTSlide As PowerPoint.Slide
Dim PPTPres As PowerPoint.Presentation
Dim PPTShape As PowerPoint.Shape


'Declare Excel Variables
Dim ExcShape As Excel.Shape
Dim WrkSht As Worksheet


'Check if PowerPoint is active
On Error Resume Next
Set PPTApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Open PowerPoint if not active
If PPTApp Is Nothing Then
Set PPTApp = New PowerPoint.Application
End If
    
'Display the PowerPoint presentation
PPTApp.Visible = True

'Create new presentation in PowerPoint
If PPTApp.Presentations.Count = 0 Then
PPTApp.Presentations.Add
End If

'Create a reference to the Active Presentation
Set PPTPres = PPTApp.ActivePresentation
    
'Locate Excel charts to paste into the new PowerPoint presentation
For Each WrkSht In ActiveWorkbook.Worksheets
    
'If the Worksheet is visible then continue on.
If WrkSht.Visible Then
    
For Each ExcShape In ActiveSheet.Shapes
        
If ExcShape.Type = msoPicture Then
            
'Create a new slide
Set PPTSlide = PPTPres.Slides.Add(PPTPres.Slides.Count + 1, ppLayoutText)
               
'Go to the new slide
PPTApp.ActiveWindow.View.GotoSlide PPTPres.Slides.Count
               
'Copy the Shape
ExcShape.Copy
               
'Paste Shape in the slide.
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
Set PPTShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
PPTShape.Select
       
'Set the dimensions of the shape.
With PPTApp.ActiveWindow.Selection.ShapeRange
.Left = 25
.Top = 150
.Width = 250
.Left = 500
End With
               
End If
            
Next ExcShape
        
End If
            
Next WrkSht

'Activate the PowerPoint App
PPTApp.Activate

'Memory clean up
Set PPTSlide = Nothing
Set PPTApp = Nothing
Set PPTShape = Nothing


End Sub

ajjava · Dec 26, 2018

Re: VBA code to copy each picture from this workbook into a blank Powerpoint? I have a little...

Thank you SOOOOOO much for your code and reply. I can't wait to try it out, and this is the perfect day for that, since nobody else is working on this day-after-Christmas

ajjava · Dec 26, 2018

Re: VBA code to copy each picture from this workbook into a blank Powerpoint? I have a little...

So, I've been playing with the code you provided, areed1192.

I ran into an issue where the code just keeps looping through the very first worksheet, copy/pasting the pics from that one page over and over again (into separate, new slides in PPT). In my particular test workbook, there are 4 picture objects on the first worksheet. When your code finishes running, I end up with 48 PPT slides, with those 4 picture objects pasted over and over in succession.

Any ideas on how to correct?

Thanks!

ajjava · Dec 26, 2018