Copying stuff to PowerPoint...checking if active presentation is the correct one when several are open

[ammdumas]

Hello...it's been a while since I've posted here, but I also haven't been deep into code for a while

Here's my problem, I have some code that copies ranges from multiple sheets to multiple slides in an existing PowerPoint template. Works like a charm. The code requires the template PowerPoint file to be open (saves having to add code for paths or selecting a file). However, in my error catching I neglected to think about what if a user has multiple PowerPoint presentations (including the template) open. So I need some code to check for the applicable template ('Account Plan Template') and if not the active presentation, abort the copy process (that part I can figure out).

This is what I have (and apologies for posting as text...I can't remember which add-in I'm supposed to use to post code...I'll take that info as well ). I think it's a With-End With statement somewhere using PowerPointApp.ActivePresentation but I suck at using With-End With. Any help is greatly appreciated.

Austin.

====

On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear

If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If

If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If

On Error GoTo 0

PowerPointApp.ActiveWindow.Panes(2).Activate
Set myPresentation = PowerPointApp.ActivePresentation

'List of PPT Slides to Paste to
MySlideArray = Array(2, 3, 4, 5, 6, 8, 9, 10, 11, 12, 13) 'go through specific slides

'List of Excel Ranges to Copy from
MyRangeArray = Array([a bunch of ranges from sheets to match slide array above...took out to keep code clean] ))

For x = LBound(MySlideArray) To UBound(MySlideArray)

MyRangeArray(x).Copy

On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=3)
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0

With myPresentation.PageSetup
shp.Left = 100
shp.Top = 140
End With
Set mySlide = myPresentation.Slides(MySlideArray(x))
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr

Next x

 

[DanteAmor]

With the following you activate your template. Change data in red by your information.

Sub Test_Pres()


    'Declare the needed variables
    Dim PowerPointApp   As PowerPoint.Application
    Dim myPresentation  As PowerPoint.Presentation
 
    'Check if PowerPoint is active
    On Error Resume Next
    Set PowerPointApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
 
    'Open PowerPoint if not active
    If PowerPointApp Is Nothing Then
        MsgBox "PowerPoint Presentation is not open, aborting."
        Sheets("Key Account Info").Select
        Exit Sub
    End If
    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Sheets("Key Account Info").Select
        Exit Sub
    End If


    'Display the PowerPoint presentation
    PowerPointApp.Visible = True
     
    'active presentation: "Account Plan Template"
    On Error Resume Next
    [COLOR=#0000ff]Set myPresentation = PowerPointApp.Presentations[/COLOR]("[B][COLOR=#ff0000]Account Plan Template.pptx[/COLOR][/B]")
    On Error GoTo 0
    If myPresentation Is Nothing Then
        MsgBox "Template could not be found, aborting."
        Exit Sub
    End If
    
    'List of PPT Slides to Paste to
    MySlideArray = Array(2, 3, 4, 5, 6, 8, 9, 10, 11, 12, 13) 'go through specific slides
    
    'List of Excel Ranges to Copy from
    MyRangeArray = Array("[a bunch of ranges from sheets to match slide array above...took out to keep code clean]")
    
    For x = LBound(MySlideArray) To UBound(MySlideArray)
        
        MyRangeArray(x).Copy
        
        On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=3)
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
        On Error GoTo 0
        
        With myPresentation.PageSetup
            shp.Left = 100
            shp.Top = 140
        End With
        Set mySlide = myPresentation.Slides(MySlideArray(x))
        mySlide.Shapes("Client").TextFrame.TextRange.Text = client
        mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
    
    Next x
End Sub

 

[ammdumas]

Hi Dante,

Perfect, thanks. Works like a charm.

Cheers,
Austin.

 

[DanteAmor]

You are welcome and thanks for the feedback