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

[ajjava]

...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):

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]

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

So here was the problem, technically we didn't have 22 slides in the presentation we had 23. The reason that error was popping up was that when we were pasting the shapes it was looking for slide 23 when there was only slide 22. In order to fix this we have changed our array loop from 41 to 42. Here is the full code for your reference:

Also I added a new variable "Dim i as integer"

Try it out and let me know if that fixes the issue.

Sub CreateExecSummary2()
'Code by areed1192
'Assumptions


'There will always be ONLY 4 images on each worksheet in the ERP workbook.
'That each of the image slides will ONLY have three shapes. Two images and 1 title box
'The first image on the slide will ALWAYS BE THE TOP ONE.
'The second image on the slide will ALWAYS BE THE BOTTOM ONE.
        
    'Declare PowerPoint Variables
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim PPTShape As PowerPoint.Shape
    Dim SldArray(44) As Variant
    Dim i As Integer
    
    'Declare Excel Variables.
    Dim filePath As String
    Dim WrkSht As Worksheet
    Dim PicCntr, SldCntr, ShpCount, StartingSld As Integer
    Dim Shp As Shape


    'Open a file dialog to go and fetch the file path, if invalid file path is presented it will exit sub.
    filePath = Excel.Application.GetOpenFilename("Executive Summary (*.pptm*),*.pptm*", _
                                                 1, "Executive Summary Template to Populate", , False)
    If filePath = "" Then GoTo noFile
    
    'Check if the PowerPoint App is open, if not create a new instance of PowerPoint and finally make the PowerPoint Visible.
    On Error Resume Next
       Set PPTApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0


    If PPTApp Is Nothing Then
       Set PPTApp = New PowerPoint.Application
    End If
    
    'Make PowerPoint Visible
    PPTApp.Visible = True


    'Set the Presentation to the file select.
    Set PPTPres = PPTApp.Presentations.Open(filePath)
    
    'Build a slide array so that way we can easily paste the pictures on the right slide.
    StartingSld = 2


    For i = 0 To 42 Step 2
        SldArray(i) = StartingSld
        SldArray(i + 1) = StartingSld
        StartingSld = StartingSld + 1
    Next
    
    PicCntr = 0
    
    'Loop through each of the worksheets in the ERP Generated Workbook
    For Each WrkSht In ActiveWorkbook.Worksheets
    
        'Activate the Worksheet, for stability issues that may arise.
        WrkSht.Activate
        
        'Loop through each shape on the Worksheet.
        For Each Shp In WrkSht.Shapes
        
            'If the shape is a picture, then continue.
            If Shp.Type = msoPicture Then
               
               'Set a reference to the slide, we select the right slide by leveraging the PicCntr.
               Set PPTSlide = PPTPres.Slides(SldArray(PicCntr))
                
                   'Copy the shape, and pause for stability issues thay may arise.
                   Shp.Copy
                   Application.Wait Now() + #12:00:01 AM#
                   
                   'Paste the shape and increase the PicCntr by 1, so that we proceed to the next element in our SldArray on the next pic.
                   PPTSlide.Shapes.Paste
                   PicCntr = PicCntr + 1
                 
               'Get the total shape count, and set a reference to the shape we want to work with.
               ShpCount = PPTSlide.Shapes.Count
               Set PPTShape = PPTSlide.Shapes(ShpCount)
               
               'Assume the First Shape is the Top one, the reason I put ShpCount 2 is because we have to include the title box.
               If ShpCount = 2 Then
                                 
                    'Set the dimensions of the shape.
                    With PPTShape
                         .Top = Excel.Application.InchesToPoints(0.42)
                         .Left = Excel.Application.InchesToPoints(2.92)
                    End With
                                   
               'Assume the Second Shape is the bottom one, the reason I put ShpCount 3 is because we have to include the title box.
               ElseIf ShpCount = 3 Then
               
                    'Set the dimensions of the shape.
                    With PPTShape
                         .Top = Excel.Application.InchesToPoints(3.92)
                         .Left = Excel.Application.InchesToPoints(2.92)
                    End With
               
               End If
            End If
        Next
    Next


'Let the user know the macro finished running.
MsgBox "The Macro has finished running, you may now work with the PowerPoint Presentation."


Exit Sub


'Handle the No File Error.
noFile:
MsgBox "We Couldn't find the file, exiting the Macro."


End Sub

 

[ajjava]

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

Ok, good news! All shapes copied over to the PPT!! Now, I'm trying to understand positioning/sizing. I don't see anything in your code that would dictate the size of each shape (and in fact, I don't think I ever mentioned anything about size). I should've done this a long time ago, but here is an example of how the "finished" slide should look, after the shapes have been pasted/sized/positioned, title box added. Given the params in Format Picture dialogue, what should I add to the code? Also, again, I can't thank you enough for your prompt and patient assistance

 

[areed1192]

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

This is the section that determines the position. I modified it to match the height and width in your photo, so just paste this over the original. Glad to hear it is finally working!

'Assume the First Shape is the Top one, the reason I put ShpCount 2 is that we have to include the title box.
If ShpCount = 2 Then
                                 
'Set the dimensions of the shape.
With PPTShape
.Top = Excel.Application.InchesToPoints(0.42)
.Left = Excel.Application.InchesToPoints(2.92)
.Height = Excel.Application.InchesToPoints(3.13)
.Width = Excel.Application.InchesToPoints(6.53)
End With
                                   
'Assume the Second Shape is the bottom one, the reason I put ShpCount 3 is that we have to include the title box.
ElseIf ShpCount = 3 Then
               
'Set the dimensions of the shape.
With PPTShape
.Top = Excel.Application.InchesToPoints[COLOR=#ff0000](3.92) CHANGE THIS SO IT MATCHES WHAT YOU HAVE FOR THE BOTTOM IMAGE.[/COLOR]
.Left = Excel.Application.InchesToPoints(2.92)
.Height = Excel.Application.InchesToPoints(3.13)
.Width = Excel.Application.InchesToPoints(6.53)
End With
               
End If

 

[ajjava]

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

More progress made. But, the first shape on each slide is seemingly unaffected by the dimensions in the code. Also, may I have the necessary code to add the rectangle text box that should appear on the left side of each slide?

 

[areed1192]

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

Add the following code after the ShpCount 3 section, this will add the text box.

         'Assume the Second Shape is the bottom one, the reason I put ShpCount 3 is because we have to include the title box.
               ElseIf ShpCount = 3 Then
               
                    'Set the dimensions of the shape.
                    With PPTShape
                         .Top = Excel.Application.InchesToPoints(3.92)
                         .Left = Excel.Application.InchesToPoints(3.15)
                    End With
               
               End If
               
[COLOR=#ff0000]               'Add the text box.[/COLOR]
[COLOR=#ff0000]               PPTSlide.Shapes.AddShape(Type:=msoShapeRectangle, Left:=38, Top:=43, Width:=317, Height:=465).TextFrame.TextRange.Text = "Please Enter Analysis Here."[/COLOR]

As for the why it's formatting the wrong shape. I can't really tell because you might have more shapes on the slide then just 3. If you do it'll throw it off, so you'll need to play around and see if the shape number is different.

 

[ajjava]

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

I understand about the number of shapes. So, about that - what does the "base" PPT look like that you've been using in your testing? For instance, does every slide have a title box and nothing else? I'm guessing that the PPT structure is, in fact, the problem, as you've said. If it's easier or more beneficial, I'm happy to send you the actual PPT.

 

[areed1192]

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

https://1drv.ms/u/s!ArYl2nzFQMaLirYP-KjEl24xo-paRA

Here is a link to the image of how I have my slides laid out. If they follow some structure like this, it should work. Maybe share a link to the file on google drive or something I can download it and see a slide and how it's laid out.

 

[ajjava]

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

YES!! I've got it all working! My slides had more shapes on them than you realized, so I had to fix that. Now, after doing that, your code works GREAT!! I just need to adjust the position/shape of the charts and then I'm good to go!!! I CANNOT THANK YOU ENOUGH FOR YOUR ASSISTANCE WITH THIS!!!!!!!!!!!!!!!!!!!!!!!

 

[areed1192]

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

YES!! I've got it all working! My slides had more shapes on them than you realized, so I had to fix that. Now, after doing that, your code works GREAT!! I just need to adjust the position/shape of the charts and then I'm good to go!!! I CANNOT THANK YOU ENOUGH FOR YOUR ASSISTANCE WITH THIS!!!!!!!!!!!!!!!!!!!!!!!

Glad you were able to get it working!