Экспорт разделов 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) ​​и, возможно, добавить кнопки пользовательского интерфейса для вызова SplitIntoSectionFiles
2. испытаний и когда удовлетворяют условию, сохранить как PowerPoint Add-In (* .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 

Читайте о пользовательском интерфейсе, если у вас нет опыта создания вам собственным вкладок ленты: msdn и использовать «Офис пользовательского интерфейс редактора», я хотел бы использовать imageMso «CreateModule» для кнопки.

Answer 2

Я не мог заставить вышеуказанный код работать.

Однако это проще и делает работу:

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 3

Ни один из предложенных процедур на самом деле не работает, поэтому я написал мое с нуля:

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 4

Я редактировал Fabios кода немного, чтобы выглядеть как это. И это хорошо работает для меня в моем компьютере

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 

Answer 5

Это работает для меня (за исключением имени файла):

Option Explicit 

Sub ExportSlidesAsPresentations() 
Dim oPres As Presentation 
Dim sSlideOutputFolder As String 

Set oPres = ActivePresentation 
sSlideOutputFolder = oPres.Path & "\" 

'Export all the slides in the presentation 
Call oPres.PublishSlides(sSlideOutputFolder, True, True) 

Set oPres = Nothing 
End Sub