VBA 以部分和标题作为文件名从 PowerPoint 导出图像

Question

我目前正在为我们企业内的一个小组开发一个解决方案，该解决方案将允许他们使用 PowerPoint 2013 从具有特定文件名的高清分辨率的 PowerPoint 演示文稿中创建幻灯片，这些特定文件名将通过不同的系统用作数字标牌'不支持 PowerPoint 文件。

我一直在寻找使用 VBA 根据需要导出文件的解决方案，但还没有完全达到目标。我自己不是 VBA 程序员，并且已经尽我所能编译了一些接近我需要的东西。

具体要求：

• 请求用户输入以导出目录
• 以 1920 x 1080 分辨率将幻灯片导出为 PNG 格式
• 仅导出文件不存在的幻灯片
• 文件名格式为[Section Name] [Slide Title] [Unique Title Number].png，如果幻灯片缺少标题，请将[Slide Title] 替换为[Placeholder Title]，示例（不带括号）：[KS4 All Temp] [20160630 20160731 Casual Dress] [1].png。
  • 每张幻灯片的唯一标题编号应从 1 开始，除非生成多张名称完全相同的幻灯片，然后该文件名的每张幻灯片的编号应增加

这是我目前的代码：

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

代码当前会生成文件，但会使用每个部分的名称复制每张幻灯片，而不仅仅是这些部分中的幻灯片。

Answer 1

一种顺序编号方法：

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