VBA to export images from PowerPoint with Section and Title as filename

Question

I'm currently working on a solution for a group within our business that will allow them to create slides using PowerPoint 2013 from a PowerPoint presentation at HD resolution with specific filenames that will be used as digital signage through a different system that doesn't support PowerPoint files.

I've been looking for a solution using VBA to export the files as required, but haven't quite hit the mark. I'm not a VBA programmer myself, and have done my best to compile something that is close to my needs.

Exact requirements:

Request input from user for directory to export to
Export slides as PNG format at 1920 x 1080 resolution
Only export slides where the file doesn't already exist
Filename format is [Section Name] [Slide Title] [Unique Title Number].png, and failing that the Slide is missing a Title, replace [Slide Title] with [Placeholder Title], example (without brackets): [KS4 All Temp] [20160630 20160731 Casual Dress] [1].png.
- The Unique Title Number should start from 1 for each slide, except where multiple slides of the exact same name are generated, then the number should increase per slide for that file name

Here is the code I have so far:

Option Explicit
Const ImageBaseName As String = "Slide_"
Const ImageWidth As Long = 1920
Const ImageHeight As Long = 1080
Const ImageType As String = "PNG"

Function fileExists(s_directory As String, s_fileName As String) As Boolean

    Dim obj_fso As Object

    Set obj_fso = CreateObject("Scripting.FileSystemObject")
    fileExists = obj_fso.fileExists(s_directory & "\" & s_fileName)

End Function

Sub ExportSlides()

    Dim oSl As Slide
    Dim Path As String
    Dim File As String
    Dim i As Long

    If ActivePresentation.Path = "" Then
        MsgBox "Please save the presentation then try again"
        Exit Sub
    End If

    Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Path"

    Path = GetSetting("FPPT", "Export", "Default Path")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select destination folder"
        If .Show = -1 And .SelectedItems.Count = 1 Then
            Path = .SelectedItems(1)
        Else: Exit Sub
        End If
    End With

    With ActivePresentation.SectionProperties
        For i = 1 To .Count
            For Each oSl In ActivePresentation.Slides
                If Not oSl.Shapes.HasTitle Then
                    File = .Name(i) & ImageBaseName & Format(oSl.SlideIndex, "0000") & "." & ImageType
                    Else: File = .Name(i) & oSl.Shapes.Title.TextFrame.TextRange.Text & Format(oSl.SlideIndex, "0000") & "." & ImageType
                End If
                If Not fileExists(Path, File) Then
                    oSl.Export Path & "\" & File, ImageType, ImageWidth, ImageHeight
                End If
            Next
        Next
    End With
End Sub

The code currently generates the files, but duplicates every slide with every section name, instead of just the slides within those sections.

You need to add some code in your loop through the slides to only process the slide if it's in Section(i) Maybe test oSl.SectionIndex ?Some code here related to working with sections: code.msdn.microsoft.com/office/PowerPoint-2010-Insert-b6f1e012 — Tim Williams
That worked pretty much perfectly, @TimWilliams. I added after the For Each oSl an If i = oSl.SectionIndex and it didn't create the duplicates. The only remaining problem is creating the unique title number. — Xaedian

Tim Williams Tim Williams · Accepted Answer · 2016-06-09T04:21:32

One approach for sequential numbering:

Dim dict As Object, sName As String
Set dict = CreateObject("scripting.dictionary")


With ActivePresentation.SectionProperties
    For i = 1 To .Count
        For Each oSl In ActivePresentation.Slides

            If Not oSl.Shapes.HasTitle Then
                sName = .Name(i) & ImageBaseName
            Else
                sName = .Name(i) & oSl.Shapes.Title.TextFrame.TextRange.Text
            End If

            dict(sName) = dict(sName) + 1
            File = sName & Format(dict(sName), "0000") & "." & ImageType

            If Not fileExists(Path, File) Then
                oSl.Export Path & "\" & File, ImageType, ImageWidth, ImageHeight
            End If
        Next
    Next
End With

VBA to export images from PowerPoint with Section and Title as filename

1 Answers