将包含章节信息的 Powerpoint 幻灯片移动（剪切和粘贴）VBA

Question

我正在寻找 select 某些幻灯片的解决方案，并在保留部分信息的同时剪切或复制并粘贴到其他位置。我看到PPT不支持开箱即用（见http://answers.microsoft.com/en-us/office/forum/office_2013_release-powerpoint/copying-sections-to-a-new-powerpoint/2c723b0d-d465-4ab6-b127-6fdfc195478c?db=5）还有一些 VBA 脚本示例 Exporting PowerPoint sections into separate files PPTalchemy 提供了一些插件，但不幸的是代码不可用。看这里http://www.pptalchemy.co.uk/powerpoint_hints_and_tips_tutorials.html#2010

此外，它不适合在同一演示文稿中轻松移动部分。

知道怎么做吗？

非常感谢。蒂埃里

Answer 1

要移动演示文稿中的某个部分，包括该部分中的所有幻灯片，请使用要移动的部分的索引及其新位置调用此过程：

Option Explicit

' ********************************************************************************
' VBA Macro for PowerPoint, written by Jamie Garroch of http://YOUpresent.co.uk/
' ********************************************************************************
' Purpose : Moves a specified section of slides to a new section location
' Inputs  : lSectionIndex - the index of the section to be moved
'           lNewPosition - the index of the position to move to
' Outputs : None.
' ********************************************************************************
Public Sub MoveSection(lSectionIndex As Long, lNewPosition As Long)
  On Error GoTo errorhandler
  With ActivePresentation
    .SectionProperties.Move lSectionIndex, lNewPosition
  End With
Exit Sub
errorhandler:
  Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Sub

Answer 2

这终于是code我用来移动幻灯片选择的多个部分：

Sub MoveSelectedSections()
' Slides are copied ready to be pasted
Dim lngNewPosition As Long
'Debug.Print ""
'Debug.Print "###Move Sections..."
lngNewPosition = InputBox("Enter a destination section index:")
lngNewPosition = CInt(lngNewPosition) ' Convert String to Int
Call MoveSectionsSelectedBySlides(ActivePresentation, lngNewPosition)

End Sub


Function MoveSectionsSelectedBySlides(oPres As Presentation, lNewPosition As Long)
  On Error GoTo errorhandler

  ' Activate input presentation
  oPres.Windows(1).Activate

  ' Get Selected Sections Indexes

  ' http://www.thespreadsheetguru.com/the-code-vault/2014/4/3/copy-selected-slides-into-new-powerpoint-presentation

    Dim i, cnt As Integer
    Dim SelectedSlides As SlideRange
    Dim SectionIndexes() As Long

    If ActiveWindow.Selection.Type <> ppSelectionSlides Then
        MsgBox "No slides selected"
        Exit Function
    End If

    Set SelectedSlides = ActiveWindow.Selection.SlideRange
    ' selection order is reverse see http://www.pptfaq.com/FAQ00869_Create_a_custom_show_from_current_slide_selection_using_VBA.htm


  'Fill an array with sectionIndex numbers
    ReDim SectionIndexes(1 To SelectedSlides.Count)
    cnt = 0
    For i = 1 To SelectedSlides.Count
    ' Check if already present in array
      If Not Contains(SectionIndexes, SelectedSlides(i).sectionIndex) Then
        cnt = cnt + 1
        SectionIndexes(cnt) = SelectedSlides(i).sectionIndex
      End If
    Next i
    ReDim Preserve SectionIndexes(1 To cnt)


    ' Move Sections to lNewPosition,  first last
    For i = 1 To cnt
        With oPres
          .SectionProperties.Move SectionIndexes(i), lNewPosition
        End With
        Debug.Print "Section #" & SectionIndexes(i) & " moved to " & lNewPosition
    Next i



Exit Function
errorhandler:
  Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Function





Function Contains(arr, v) As Boolean
' 
Dim rv As Boolean, i As Long ' Default value of boolean is False
For i = LBound(arr) To UBound(arr)
    If arr(i) = v Then
       rv = True
       Exit For
    End If
Next i
Contains = rv
End Function

将包含章节信息的 Powerpoint 幻灯片移动（剪切和粘贴）VBA

Move (Cut&Paste) Powerpoint Slides with Sections information by VBA

powerpoint

vba