CODEWITHSUNDEEP
excelvbapowerpoint
Gary Coburn
Gary Coburn

Reputation: 1

Open PowerPoint presentation and run a PowerPoint macro in another presentation from Excel

I have 500,000 slides across 55,000 presentations. I would like to add a picture to each slide.

I can open the presentations from Excel however I then have to manually add a macro to one of the presentations and set it to loop through.

I found that opening 50 presentations at a time stops the system from crashing out of memory. This is laborious. I would like to open each file run the macro, close the file and use Excel to loop through all the files.

Code to open the file.

Sub Open_PPT_Irregular_Files()

    Dim arrPPTFiles(500) As Variant 'Change value to amount of presentations
    Dim DestinationPPT As String
    Dim PowerPointApp As PowerPoint.Application
    Dim myPresentation As PowerPoint.Presentation

    Dim i, v, w, x, y, z As Integer
    Dim strT As String
    v = 500 'Change value to amount of presentations

    w = 0 'Halting position to stop running out of memory
    x = 1 'Starting cell position update as required
    y = 9 'Ending cell position update as required

    Dim arrPPT(500) As Variant 'Change value to amount of presentations

    Sheets("PPTIrregular").Select
    'I hold the path to all the presentations on this sheet.... populated from a recursive query

    For i = 1 To v
        arrPPT(i) = Range("A" & i).Value2
    Next

    Set PowerPointApp = CreateObject("PowerPoint.Application")
    
    For i = 1 To v
        DestinationPPT = arrPPT(i) '"path"
        PowerPointApp.Presentations.Open (DestinationPPT)
        PowerPointApp.ActiveWindow.WindowState = ppWindowMinimized
       'Application.Run "Copyright.xlsm!Paste_CopyrightPPT.Paste_CopyrightPPT"

        If w = 50 Then
            'at this point i select manually a presentation and then import the macro to it and loop x 50 times
            'before continuing the code for next 50 etc...
            Stop
            w = 0
        End If
        
        w = w + 1

    Next
End Sub

Code to run the PowerPoint macro I add manually.

Sub callCopyRight()
    For i = 1 To 50
        Call Paste_CopyrightPPT
    Next
End Sub


Sub Paste_CopyrightPPT()

    'PowerPoint Macro Only! Not tested in excel yet.
    ' In order to run this code first make sure the logo exists in objImageBox

    Dim i, y, z As Integer
    Dim objPresentaion As Presentation
    Dim objSlide As Slide
    Dim objImageBox As Shape

    i = 2
    y = ActivePresentation.Slides.Count
    z = 2

    For i = 1 To y

        Set objPresentaion = ActivePresentation
        Set objSlide = objPresentaion.Slides.Item(i)

        'Storing the picture below...
         Set objImageBox = objSlide.Shapes.AddPicture("C:\Users\Gazza\Desktop\_MasterBreakdowns        '\Copyright.jpg", msoCTrue, msoCTrue, 100, 100)
    
        objSlide.Shapes.Item(2).Top = 1
        objSlide.Shapes.Item(2).Left = 1
        objSlide.Shapes.Item(2).Width = 60
        objSlide.Shapes.Item(2).Height = 15

    Next

    PowerPoint.ActivePresentation.Slides(1).Select
    PowerPoint.ActivePresentation.Save
    PowerPoint.ActivePresentation.Close
End Sub

I need to run a variation of this code from Excel on a presentation by presentation basis.

Upvotes: 0

Views: 525

Answers (2)

Gary Coburn
Gary Coburn

Reputation: 1

I decided to try to do everything within PowerPoint.

Public Sub DoFilesMulti()

Dim k As Integer
Dim arrLists(19) As Variant

arrLists(1) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\01_Indicative Present\Regular\"
arrLists(2) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\02_Indicative Future\Regular\"
arrLists(3) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\03_Indicative Imperfect\Regular\"
arrLists(4) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\04_Indicative Preterite\Regular\"
arrLists(5) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\05_Indicative Conditional\Regular\"
arrLists(6) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\06_Perfect Present Perfect\Regular\"
arrLists(7) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\07_Perfect Future Perfect\Regular\"
arrLists(8) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\08_Perfect Pluperfect\Regular\"
arrLists(9) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\09_Perfect Conditional Perfect\Regular\"
arrLists(10) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\10_Perfect Past Anterior\Regular\"
arrLists(11) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\11_Subjunctive Present\Regular\"
arrLists(12) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\12_Subjunctive Imperfect\Regular\"
arrLists(13) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\13_Subjunctive Imperfect 2\Regular\"
arrLists(14) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\14_Subjunctive Future\Regular\"
arrLists(15) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\15_Subjunctive Perfect Present Perfect\Regular\"
arrLists(16) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\16_Subjunctive Perfect Future Perfect\Regular\"
arrLists(17) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\17_Subjunctive Perfect Pluperfect\Regular\"
arrLists(18) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\18_Subjunctive Perfect Pluperfect 2\Regular\"
arrLists(19) = "C:\Users\Gazza\Desktop\_MasterBreakdowns\19_Commands Imperative\Regular\"
k = 14 'Starting point......

For k = 1 To 19
    
    Dim strFileName As String
    Dim strFolderName As String
    Dim PP As Presentation
    'set default directory here if needed
    strFolderName = arrLists(k)
    strFileName = Dir(strFolderName & "\*.ppt*")
    Do While Len(strFileName) > 0
        Set PP = Presentations.Open(strFolderName & "\" & strFileName)
        'your code
    
        ' In order to run this code first make sure the logo exists in objImageBox
     
        Dim i, y, z As Integer
        Dim objPresentaion As Presentation
        Dim objSlide As Slide
        Dim objImageBox As Shape
    
        i = 2
        y = ActivePresentation.Slides.Count
        z = 2
    
        For i = 1 To y
        
            Set objPresentaion = ActivePresentation
            Set objSlide = objPresentaion.Slides.Item(i)
        
            Set objImageBox = objSlide.Shapes.AddPicture("C:\Users\Gazza\Desktop\_MasterBreakdowns\00_Macros\Copyright.jpg", msoCTrue, msoCTrue, 100, 100)
        
            objSlide.Shapes.Item(2).Top = 1
            objSlide.Shapes.Item(2).Left = 1
            objSlide.Shapes.Item(2).Width = 60
            objSlide.Shapes.Item(2).Height = 15
        
        Next
        PowerPoint.ActivePresentation.Slides(1).Select
        PowerPoint.ActivePresentation.Save
        PowerPoint.ActivePresentation.Close
          
        strFileName = Dir
    Loop

Next
End Sub

Upvotes: 0

Tim Williams
Tim Williams

Reputation: 166755

You can try this:

Const IMG_PATH As String = "C:temp\Copyright.jpg" 'for example

Sub Open_PPT_Irregular_Files()
    Dim PowerPointApp As PowerPoint.Application, myPres As PowerPoint.Presentation
    Dim i As Long, wsList As Worksheet
    
    Set wsList = ThisWorkbook.Sheets("PPTIrregular")
    Set PowerPointApp = CreateObject("PowerPoint.Application")
    PowerPointApp.Visible = True
 
    For i = 1 To 500
        Set myPres = PowerPointApp.Presentations.Open(wsList.Cells(i, "A").Value)
        UpdatePres myPres
        myPres.Save
        myPres.Close
    Next i
End Sub

Sub UpdatePres(pres As PowerPoint.Presentation)
    Dim sld As PowerPoint.Slide
    For Each sld In pres.Slides
        sld.Shapes.AddPicture fileName:=IMG_PATH, linktofile:=msoFalse, _
                              savewithdocument:=msoTrue, Top:=1, Left:=1, _
                              Width:=60, Height:=15
    Next sld
End Sub

If the slides all use the same Master it might be faster to add the image there, instead of to each individual slide.

Upvotes: 1

Related Questions