Consulting

Results 1 to 3 of 3

Thread: Split PPT presentation and save PDFs

  1. #1
    VBAX Newbie
    Joined
    Feb 2020
    Posts
    2
    Location

    Split PPT presentation and save PDFs

    Dear all,

    We have a PPT presentation which includes 131 slides. On a monthly basis we have to split the presentation into several smaller team-presentations, generate a PDF and send them via email.
    We already have a VBA in place in order to split the presentation. I am quite new to VBA and trying now that I can save the documents directly as PDFs.
    I am trying back and forth for days now but I do not get the result I am looking for.
    The perfect way would be:
    - I can run one macro and automatically all team presentations are saved as PDF in the specific team folders.
    What happens when I run the macro now is:
    - I run the macro (1 macro per team presentation), it generates and opens a new PPT with the requested slides (e.g. 22 slides) which I can then click on Save in order that it saves it in the requested folder. Additionally, it saves a PDF of the total 131 slides in the same team folder (whereas I would be looking for the PDF only containing the 22 slides).

    I am copying the VBA macro for two teams as an example, in total we have 13 teams.

    Sub ABC()
    
    ' Variable definitions
    Dim oSld As Slide
    Dim oShp As Shape
    Dim lTotalSlides As Long
    Dim Slidenumber, SlidesNeeded, Team As String
    Dim strResponse As String
    
    ' Defining the date used in nomenclature of file
    myDate = Format(Date, "_yyyy_mm_dd")
    
    'Define team name
    Team = "ABC"
    
    ' Saving paths
    ActivePresentation.ExportAsFixedFormat "O:\ABC" & myDate & ".pdf", ppFixedFormatTypePDF
    
    ' Finding the numbers of the required slides
    Slidenumber = "" ' define an empty variable for later use
    SlidesNeeded = "14,15,16,17,18,29,30,40,55,56,70,85,113,127,1 28" 'define the basic slides (dividers, etc. that are need in any presentation) -> may need adjustment from time to time
    
    lTotalSlides = ActivePresentation.Slides.Count
    
    For Each oSld In ActivePresentation.Slides
    For Each oShp In oSld.Shapes
    If oShp.HasTextFrame Then
    If oShp.TextFrame.TextRange.Find(Team) Is Nothing Then
    Else: Slidenumber = oSld.Slidenumber
    SlidesNeeded = SlidesNeeded & "," & Slidenumber ' expands the SlidesNeeded with the slides that contain the team name in the title
    End If
    End If
    Next
    Next
    
    
    ' Deleting all unnecessary slides
    Dim x As Long
    Dim lSlideNumber As Long
    Dim rayKeep() As String
    Dim bKeeper As Boolean
    Dim oPres As Presentation
    
    rayKeep() = Split(SlidesNeeded, ",")
    
    Set oPres = ActivePresentation
    With oPres
    For lSlideNumber = .Slides.Count To 1 Step -1
    For x = LBound(rayKeep) To UBound(rayKeep)
    If .Slides(lSlideNumber).SlideIndex = CLng(rayKeep(x)) Then
    '.Slides(lSlideNumber).Delete
    bKeeper = True
    End If
    Next
    
    If Not bKeeper Then
    .Slides(lSlideNumber).Delete
    End If
    bKeeper = False
    
    Next
    End With
    
    End Sub
    
    Sub CEE()
    
    Dim oSld As Slide
    Dim oShp As Shape
    Dim lTotalSlides As Long
    Dim Slidenumber, SlidesNeeded, Team As String
    Dim strResponse As String
    
    myDate = Format(Date, "_yyyy_mm_dd")
    Team = "CEE"
    
    ActivePresentation.ExportAsFixedFormat "O:\CEE" & myDate & ".pdf", ppFixedFormatTypePDF
    
    Slidenumber = "" ' define an empty variable for later use
    SlidesNeeded = "14,15,16,17,18,29,30,40,55,56,70,85,113,127,1 28" 'define the basic slides (dividers, etc. that are need in any presentation) -> may need adjustment from time to time
    
    lTotalSlides = ActivePresentation.Slides.Count
    
    For Each oSld In ActivePresentation.Slides
    For Each oShp In oSld.Shapes
    If oShp.HasTextFrame Then
    If oShp.TextFrame.TextRange.Find(Team) Is Nothing Then
    Else: Slidenumber = oSld.Slidenumber
    SlidesNeeded = SlidesNeeded & "," & Slidenumber ' expands the SlidesNeeded with the slides that contain the team name in the title
    End If
    End If
    Next
    Next
    
    
    ' Deleting all unnecessary slides
    Dim x As Long
    Dim lSlideNumber As Long
    Dim rayKeep() As String
    Dim bKeeper As Boolean
    Dim oPres As Presentation
    
    rayKeep() = Split(SlidesNeeded, ",")
    
    Set oPres = ActivePresentation
    With oPres
    For lSlideNumber = .Slides.Count To 1 Step -1
    For x = LBound(rayKeep) To UBound(rayKeep)
    If .Slides(lSlideNumber).SlideIndex = CLng(rayKeep(x)) Then
    '.Slides(lSlideNumber).Delete
    bKeeper = True
    End If
    Next
    
    If Not bKeeper Then
    .Slides(lSlideNumber).Delete
    End If
    bKeeper = False
    
    Next
    End With
    
    End Sub


    Any help would me much appreciated!! Already many thanks in advance!
    Best, Sonja
    Last edited by Paul_Hossler; 05-11-2020 at 10:14 AM. Reason: Added CODE tags

  2. #2
    VBAX Contributor
    Joined
    Dec 2018
    Location
    South London
    Posts
    115
    Location
    Hi Sonj

    No idea if you can adapt this, but if you have the large 131 file and create sections (right click to make Sections in the left side slide sorter column) and then this code will save each section as a separate PDF in the same folder. It's code I had, no doubt helped by John , I just changed the original .pptx to .pdf in line " .SaveAs FileName:=.path & outputFname & ".pdf" So I hope it works.


    Option Explicit
    
    
    Sub SplitFile()
        Dim original_File       As Presentation
        Dim File_Segment        As Presentation
        Dim File_name           As String
        Dim DupeName            As String
        Dim outputFname         As String
        Dim origName            As String
        Dim lIndex              As Long
        Dim K                   As Long
        Dim pathSep             As String
    
    
        pathSep = ":"
        #If Mac Then
            pathSep = ":"
        #Else
            pathSep = "/"
        #End If
    
    
        Set original_File = ActivePresentation
        DupeName = "TemporaryFile.pptx"
        DupeName = original_File.path & pathSep & DupeName
        original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
        origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)
    
    
        For lIndex = 1 To original_File.SectionProperties.Count
            If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
                Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
                File_name = File_Segment.SectionProperties.Name(lIndex)
    
    
                For K = original_File.SectionProperties.Count To 1 Step -1
                    If File_Segment.SectionProperties.Name(K) <> File_name Then
                        Call File_Segment.SectionProperties.Delete(K, 1)
                    End If
                Next K
    
    
                outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")
    
    
                With File_Segment
                    .SaveAs FileName:=.path & outputFname & ".pdf", FileFormat:=ppSaveAsOpenXMLPresentation
                    .Close
                End With
                Set File_Segment = Nothing
            End If
        Next
    
    
        Set original_File = Nothing
        Kill DupeName
        MsgBox "Split completed successfully!"
    
    
    End Sub
    Last edited by Paul_Hossler; 05-11-2020 at 11:13 AM. Reason: Added [CODE] tags

  3. #3
    VBAX Newbie
    Joined
    Feb 2020
    Posts
    2
    Location
    Dear RayKay,
    Many thanks for your reply and your help, very much appreciated!
    Sorry for my late reply but I now finally had the time to check your reply and the VBA.
    Unfortunately, the thing with the sections does not work . Some slides in the presentation are needed for each single team presentation, and I cannot add one slide to several sections.
    Additionally, the team slides are not in one order..
    But thank you nevertheless.

    Best,
    Sonja

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •