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

 

[ajjava]

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

This is a little more complicated. Is it always two images on a slide? Is it only certain worksheets? All these questions and more have to be answered in order to build the script properly. However, in a general sense, we just need to specify the slide we want to work with so, for example, we can simply add this line of code after we add a new slide:

'Specify the slide we want to work with
Set PPTSlide = PPTPres.Slides(Index)

Where the index is the slide number in the presentation.

Here is an overview of what I'm ultimately trying to do:
An Excel workbook will be generated from our ERP system (SAP/Business Objects)
It will contain a fixed number of worksheets
Each worksheet will contain 4 pictures (the pictures started their lives as Charts in BizObj, but are converted via export into pic format)
Each time a workbook is generated from our ERP (on-demand and by specific client), all of the contents in the workbook will need to be copy/pasted into a predefined PPT presentation template
Each slide should contain 2 pictures, positioned as I mentioned above (in inches, roughly 2.92/0.42 for the top pic and 2.92/3.92 for the bottom pic - 210/30 & 210/282 in points)

Whomever was in my role before me was able to build an INCREDIBLE series of VBA scripts that carried out all of the above, and more. But that script was working with actual charts, not pictures. The process has now changed entirely and I'm trying to be the hero by coming up with a way to somewhat replicate what my predecessor created. (Sidebar: Of course, the change that was implemented has simplified some aspects of the process, while WAYYYYY over-complicated many others - whomever performed the cost/benefit analysis really dropped the ball, IMHO). Anyway, here is one of the scripts (from PPT), just so you can get a feel for the complexity:

Sub populateExecutiveSummary()
Dim pptApp As PowerPoint.Application
Dim PA_Presentation As PowerPoint.Presentation, ES_Presentation As PowerPoint.Presentation
Dim PA_slide As PowerPoint.Slide, ES_slide As PowerPoint.Slide
Dim PA_shape As PowerPoint.Shape, ES_Shape As PowerPoint.Shape
Dim SINGLE_TOP_ADJUST As Double, SINGLE_LEFT_ADJUST As Double, SINGLE_LEFT_ADJUST_narrow As Double
Dim DOUBLE_TOP_ADJUST As Double, DOUBLE_LEFT_ADJUST As Double, DOUBLE_Bottom_ADJUST As Double
Dim TITLE_TOP_ADJUST As Double, TITLE_LEFT_ADJUST As Double
Dim ES_SlideName As String, ES_SlideName_prev As String, ES_SlideName_send As String, ES_SlideCounter As Integer
Dim filePath As Variant
Dim wsCount As Integer
Dim I1 As Integer
Dim wsTagName As String
Dim wsNmbrOfGraphs As Integer
Dim SecondGraph As String
Dim wsWidth As Single
Dim wsShapename As String
Dim Title1Text As String
Dim SlideShapeCount As Integer
Dim wsGraphType As String
SINGLE_TOP_ADJUST = excel.Application.InchesToPoints(1.13)
SINGLE_LEFT_ADJUST = excel.Application.InchesToPoints(1.08)
SINGLE_LEFT_ADJUST_narrow = excel.Application.InchesToPoints(1.67)
DOUBLE_TOP_ADJUST = excel.Application.InchesToPoints(0.79)
DOUBLE_Bottom_ADJUST = excel.Application.InchesToPoints(3.96)
DOUBLE_LEFT_ADJUST = excel.Application.InchesToPoints(3.15)
TITLE_TOP_ADJUST = excel.Application.InchesToPoints(3)
TITLE_LEFT_ADJUST = excel.Application.InchesToPoints(1.3)
ES_SlideCounter = 1
ES_SlideName = "Summary"
ES_SlideName_prev = "Summary"
Set PA_Presentation = Application.ActivePresentation
'-------------------------------------------------------------------------------------
filePath = excel.Application.GetOpenFilename("Executive Summary (*.pptm*),*.pptm*", _
1, "Executive Summary Template to Populate", , False)
    If filePath = False Then GoTo noFile
Set ES_Presentation = Application.Presentations.Open(filePath)
'--------------------------------------------------------------------------------------
filePath = Replace(filePath, "pptm", "txt")
Open filePath For Output As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
For Each PA_slide In PA_Presentation.Slides
    
    'get the text from Title 1
    Title1Text = ""
    SlideShapeCount = PA_slide.Shapes.Count
    For I1 = 1 To SlideShapeCount Step 1
      If PA_slide.Shapes(I1).name = "Title 1" Then
        If PA_slide.Shapes(I1).HasTextFrame Then
          If PA_slide.Shapes(I1).TextFrame.HasText Then
            Title1Text = PA_slide.Shapes(I1).TextFrame.TextRange.Text
            Exit For
          End If
        End If
      End If
    Next I1
    'find out how many graphs on the PA slide get put on the ES slide with the tags on the shape
    wsNmbrOfGraphs = 0
    For Each PA_shape In PA_slide.Shapes
        'single graph on the slide
        If PA_slide.Tags("addSingleES") = "True" _
        And PA_shape.Tags.Item("Single") = "True" Then
            wsNmbrOfGraphs = wsNmbrOfGraphs + 1
        End If
        'just the top slide selected of a 2 graph slide
        If PA_slide.Tags("addTopES") = "True" _
        And PA_shape.Tags.Item("Top") = "True" Then
            wsNmbrOfGraphs = wsNmbrOfGraphs + 1
        End If
        'just the bottom slide selected of a 2 graph slide
        If PA_slide.Tags("addBottomES") = "True" _
        And PA_shape.Tags.Item("Bottom") = "True" Then
            wsNmbrOfGraphs = wsNmbrOfGraphs + 1
        End If
    Next PA_shape
    'take the selected graphs from the PA and put them on the ES
    SecondGraph = "N"
    For Each PA_shape In PA_slide.Shapes
        wsGraphType = ""
        
        'put the title shape on the ES
        If PA_shape.Tags.Item("titleShape") = "True" Then
            wsGraphType = "Title"
            copyChart PA_shape, ES_Presentation.Slides(ES_SlideName), TITLE_TOP_ADJUST, TITLE_LEFT_ADJUST, _
              ES_SlideName, ES_SlideName_prev, ES_SlideCounter, SecondGraph, wsShapename, Title1Text, wsGraphType
        End If
        
        'put the graph on the ES for slides with just one graph on the PA
        If PA_slide.Tags("addSingleES") = "True" _
        And PA_shape.Tags.Item("Single") = "True" Then
            wsWidth = PA_shape.Width
            wsGraphType = "Single"
            copyChart PA_shape, ES_Presentation.Slides(ES_SlideName), SINGLE_TOP_ADJUST, SINGLE_LEFT_ADJUST, _
              ES_SlideName, ES_SlideName_prev, ES_SlideCounter, SecondGraph, wsShapename, Title1Text, wsGraphType
        End If
        
        'put the top graph on the ES for slides with just the top graph selected
        If PA_slide.Tags("addTopES") = "True" _
        And PA_shape.Tags.Item("Top") = "True" _
        And wsNmbrOfGraphs = 1 Then
            wsGraphType = "Top Only"
            copyChart PA_shape, ES_Presentation.Slides(ES_SlideName), SINGLE_TOP_ADJUST, SINGLE_LEFT_ADJUST_narrow, _
              ES_SlideName, ES_SlideName_prev, ES_SlideCounter, SecondGraph, wsShapename, Title1Text, wsGraphType
        End If
        
        'put the bottom graph on the ES for slides with just the bottom graph selected
        If PA_slide.Tags("addBottomES") = "True" _
        And PA_shape.Tags.Item("Bottom") = "True" _
        And wsNmbrOfGraphs = 1 Then
            wsGraphType = "Bottom Only"
            copyChart PA_shape, ES_Presentation.Slides(ES_SlideName), SINGLE_TOP_ADJUST, SINGLE_LEFT_ADJUST_narrow, _
              ES_SlideName, ES_SlideName_prev, ES_SlideCounter, SecondGraph, wsShapename, Title1Text, wsGraphType
        End If
        
        'put the top graph on the ES for slides with 2 graphs selected
        If PA_slide.Tags("addTopES") = "True" _
        And PA_shape.Tags.Item("Top") = "True" _
        And wsNmbrOfGraphs = 2 Then
            If SecondGraph = "N" Then
               ES_SlideName_send = ES_SlideName
            Else
               ES_SlideName_send = ES_SlideName_prev
            End If
            wsGraphType = "Top"
            copyChart PA_shape, ES_Presentation.Slides(ES_SlideName_send), DOUBLE_TOP_ADJUST, DOUBLE_LEFT_ADJUST, _
              ES_SlideName, ES_SlideName_prev, ES_SlideCounter, SecondGraph, wsShapename, Title1Text, wsGraphType
            SecondGraph = "Y"
        End If
        
        'put the bottom graph on the ES for slides with 2 graphs selected
        If PA_slide.Tags("addBottomES") = "True" _
        And PA_shape.Tags.Item("Bottom") = "True" _
        And wsNmbrOfGraphs = 2 Then
            If SecondGraph = "N" Then
               ES_SlideName_send = ES_SlideName
            Else
               ES_SlideName_send = ES_SlideName_prev
            End If
            wsGraphType = "Bottom"
            copyChart PA_shape, ES_Presentation.Slides(ES_SlideName_send), DOUBLE_Bottom_ADJUST, DOUBLE_LEFT_ADJUST, _
              ES_SlideName, ES_SlideName_prev, ES_SlideCounter, SecondGraph, wsShapename, Title1Text, wsGraphType
            SecondGraph = "Y"
        End If
    Next PA_shape
Next PA_slide
    
On Error GoTo noFile
ES_Presentation.Slides(ES_SlideName).Delete
'MsgBox ("The Macro has Finished")
noFile:
Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] 
End Sub

 

[areed1192]

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

Sorry, I got a little busy yesterday, so I wasn't able to look at this till just now. I went ahead and made a script that should achieve the bulk of what you're doing, but I made a ton of assumptions, so it is by no means perfect. Ideally, you'll be able to look at this code and modify it to fit your unique situation.

Just so you're aware I wanted you to know the assumptions I made in this script.

• The presentation will always have nine slides — one for the title page and 8 for the images.
• 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.
• This script is not adjusting the TITLE BOX, you will need to add that.

With these assumptions, you should be able to look at my code and decipher the intent with relative ease. As always please don't hesitate to ask clarifying questions, I tried to put in a bunch of comments, but I also know sometimes that doesn't still do the trick.

Sub CreateExecSummary()
        
    '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 As Variant
    
    'Declare Excel Variables.
    Dim filePath As String
    Dim WrkSht As Worksheet
    Dim PicCntr, SldCntr, ShpCount 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 we can easily paste the pictures on the right slide.
    SldArray = Array(2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9)
    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 that 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 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)
                    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(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?

Everything goes well until this line of code. I really tried, but it's beyond me to figure out why it gets angry at this spot. Any ideas?

 

[ajjava]

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

Everything goes well until this line of code. I really tried, but it's beyond me to figure out why it gets angry at this spot. Any ideas?

Is the problem the fact that I'll ultimately have 22 slides in the PPT? The ERP workbook will always be 11 tabs with 4 pic/shapes each, thereby making the PPT 22 slides (at 2 pic/shapes per slide)?

 

[areed1192]

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

Is the problem the fact that I'll ultimately have 22 slides in the PPT? The ERP workbook will always be 11 tabs with 4 pic/shapes each, thereby making the PPT 22 slides (at 2 pic/shapes per slide)?

Yes, that will cause a problem because it probably is coming up with an error that says it is out of range. What we have to do is increase our slide array to handle all 22 slides.

In this case, let's use a loop to build the slide array. Replace the following code:

[COLOR=#574123] '[/COLOR]Build a slide array so we can easily paste the pictures on the right slide.
 SldArray = Array(2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9)

With the following:

    'Build a slide array so that way we can easily paste the pictures on the right slide.
    StartingSld = 2


    For i = 0 To 41 Step 2
        SldArray(i) = StartingSld
        SldArray(i + 1) = StartingSld
        StartingSld = StartingSld + 1
    Next

This will produce a slide array that goes from slide 2 to 22 (the number of slides you have). To prove it simply print it out:

    For i = LBound(SldArray) To UBound(SldArray)
        Debug.Print (SldArray(i))
    Next i

Let me know if this fixes the problem. The biggest problem is making sure that the Slide array only loops through the slides we don't want aka the title slide.

 

[ajjava]

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

It starts off ok, but then this error comes up:

Do I need to declare some sort of variable for "StartlingSld"?

 

[areed1192]

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

Here is the full code, it's because there isn't a variable called "StartingSld" declared. If you have option Explicit at the top you need to have all your variables declared.

Option Explicit


Sub CreateExecSummary()
        
    '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
    
    '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 41 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?

Now I'm getting this message, after copy/pasting your latest code:

 

[areed1192]

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

Can you paste your code? I'm not getting any errors on my end when I run it.

 

[ajjava]

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

The PPTpres that the procedure opens should have the correct number of blank slides, before running the code, right? Maybe I'm having an issue in PPT?

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