Question

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

我一直在寻找使用VBA根据需要导出文件的解决方案，但还没有达到标准。我自己并不是VBA程序员，并且尽力编译符合我需求的东西。

确切要求：

请求用户输入要导出到
以1920 x 1080分辨率
仅导出文件尚未存在的幻灯片
文件名格式为[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

VBA从PowerPoint导出图像，其中Section和Title作为文件名

1 个答案: