1

我目前正在为我们业务中的一个团队开发一个解决方案，该解决方案将允许他们使用 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

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

4

1 回答 1

2

顺序编号的一种方法：

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
于 2016-06-09T04:21:32.903 回答