vba - PowerPoint セクションを個別のファイルにエクスポートする

Question

毎週、長い PowerPoint ファイルを複数のファイルに分けています。ファイルは PowerPoint 形式である必要があり、PowerPoint ファイルの「セクション」に含まれるスライドのみが含まれている必要があります。

1) 特定のセクション内のスライド数を確認するため
にスキャンする
2) そのセクション内のスライドを含むファイルを作成する
3) そのファイルにセクションの名前と同じ名前を付けて、同じディレクトリに保存するソースファイル。
4) 後続のセクションに対してプロセスを繰り返します。
5) 元のファイルを損傷することなくこれを行います。

ファイルを多くの部分に分割できるコード ( http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm ) を見つけましたが、ファイルごとに要求されたファイルの数によってのみです。ここで他の役立つ参考文献を見つけました: http://skp.mvps.org/2010/ppt001.htm

私は Basic といくつかの簡単なゲーム スクリプト言語でコーディングしました。これが VBA でどのように行われるかを理解するのに助けが必要です。

Answer 1

これは頻繁に行うため、このためのアドインを作成する必要があります。アイデアは、プレゼンテーションのセクションの数までプレゼンテーションのコピーを作成し、それぞれを開いて他のセクションを削除して保存することです。

1. マクロを有効にして空白のプレゼンテーション (*.pptm) を作成し、カスタム UI ボタン​​を追加して呼び出します。SplitIntoSectionFiles
2. テストして満足したら、PowerPoint アドイン (*.ppam) として保存します。pptm ファイルを削除しないでください。

扱っているすべてが pptx ファイルであると仮定すると、このコードを使用できます。分割された pptx ファイルをバックグラウンドで開き、無関係なセクションを削除して保存し、閉じます。すべてがうまくいけば、メッセージ ボックスが表示されます。

Private Const PPT_EXT As String = ".pptx"

Sub SplitIntoSectionFiles()
    On Error Resume Next
    Dim aNewFiles() As Variant, sPath As String, i As Long

    With ActivePresentation
        sPath = .Path & "\"
        For i = 1 To .SectionProperties.Count
            ReDim Preserve aNewFiles(i)
            ' Store the Section Names
            aNewFiles(i - 1) = .SectionProperties.Name(i)
            ' Force Save Copy as pptx format
            .SaveCopyAs sPath & aNewFiles(i - 1), ppSaveAsOpenXMLPresentation
            ' Call Sub to Remove irrelevant sections
            RemoveOtherSections sPath & aNewFiles(i - 1) & PPT_EXT
        Next
        If .SectionProperties.Count > 0 And Err.Number = 0 Then MsgBox "Successfully split " & .Name & " into " & UBound(aNewFiles) & " files."
    End With
End Sub

Private Sub RemoveOtherSections(sPPT As String)
    On Error Resume Next
    Dim oPPT As Presentation, i As Long

    Set oPPT = Presentations.Open(FileName:=sPPT, WithWindow:=msoFalse)
    With oPPT
        ' Delete Sections from last to first
        For i = .SectionProperties.Count To 1 Step -1
            ' Delete Sections that are not in the file name
            If Not InStr(1, .Name, .SectionProperties.Name(i), vbTextCompare) = 1 Then
                ' Delete the Section, along with the slides associated with it
                .SectionProperties.Delete i, True
            End If
        Next
        .Save
        .Close
    End With
    Set oPPT = Nothing
End Sub

独自のリボン タブを作成した経験がない場合は、カスタム UI についてお読みください: msdnを使用し、「Office カスタム UI エディター」を使用します。

Answer 2

提案されたルーチンはどれも実際には機能しないので、私は自分のものをゼロから書きました:

Sub Split()

Dim original_pitch As Presentation
Set original_pitch = ActivePresentation

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

With original_pitch
    .SaveCopyAs _
        FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
        FileFormat:=ppSaveAsOpenXMLPresentation
End With

Dim i As Long
    For i = 1 To original_pitch.SectionProperties.Count

        Dim pitch_segment As Presentation
        Set pitch_segment = Presentations.Open(Replace(original_pitch.FullName, "pptm", "pptx"))

        section_name = pitch_segment.SectionProperties.Name(i)

        For k = original_pitch.SectionProperties.Count To 1 Step -1
            If pitch_segment.SectionProperties.Name(k) <> section_name Then pitch_segment.SectionProperties.Delete k, True
        Next k

        With pitch_segment
            .SaveCopyAs _
            FileName:=fso.BuildPath(.Path, original_pitch.SectionProperties.Name(i) & ".pptx"), _
            FileFormat:=ppSaveAsOpenXMLPresentation
            .Close
        End With

    Next i

MsgBox "Split completed successfully!"

End Sub

Answer 3

上記のコードを機能させることができませんでした。

ただし、これはより簡単で機能します。

Sub SplitToSectionsByChen()
 daname = ActivePresentation.Name

 For i = 1 To ActivePresentation.SectionProperties.Count
   For j = ActivePresentation.SectionProperties.Count To 1 Step -1

    If i <> j Then ActivePresentation.SectionProperties.Delete j, True

   Next j

  ActivePresentation.SaveAs ActivePresentation.SectionProperties.Name(1)
  ActivePresentation.Close
  Presentations.Open (daname)

 Next i

End Sub

Answer 4

fabios コードを少し編集して、このようにしました。そして、これは私のPCでうまく機能します

    Option Explicit

Sub Split()
    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 & ".pptx", FileFormat:=ppSaveAsOpenXMLPresentation
                .Close
            End With
            Set File_Segment = Nothing
        End If
    Next

    Set original_File = Nothing
    Kill DupeName
    MsgBox "Split completed successfully!"

End Sub