Creating a new presentation by pulling slides from a presentation

Imports System.IO
Imports System.IO.Packaging
Imports System.Xml
Public Class Form1
    Dim ppt As New pptHelper
    Private Sub SelectFile_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles SelectFile.Click
        Dim rs As DialogResult
        Dim items() As Object = Nothing

        OpenFileDialog1.Filter = "PowerPoint Presentation|*.pptx"
        rs = OpenFileDialog1.ShowDialog()

        If rs = Windows.Forms.DialogResult.OK Then
            SlideList.Items.Clear()
            items = ppt.GetSlideTitles(OpenFileDialog1.FileName).ToArray()
            SlideList.Items.AddRange(items)
        End If
    End Sub

    Public Sub MoveSlide(ByVal filename As String, ByVal slidetitle As String, ByVal remove As Boolean) ' function which will be called from "move" and "move all" 

        SelectedSlides.Items.Add(slidetitle) ' add it to the selected slide list
        If remove Then
            SlideList.Items.Remove(SlideList.SelectedItem) ' removing it from the slidelist (just to ensure that you don't add slides multiple times)
        End If
    End Sub
    Private Sub Move_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles SelectSlide.Click
        MoveSlide(OpenFileDialog1.FileName, SlideList.SelectedItem.ToString, True)
    End Sub
    Private Sub MoveAll_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles SelectAll.Click

        For Each o As Object In SlideList.Items ' Iterating through the listbox and moving everything to selected file list
            MoveSlide(OpenFileDialog1.FileName, o.ToString, False)
        Next o

        SlideList.Items.Clear() ' clearing the list
    End Sub



    Private Sub CreatePresentation_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CreatePresentation.Click
        Dim rs As DialogResult
        Dim source As Package = Nothing
        Dim target As Package = Nothing
        'Dim p As Package = Nothing

        SaveFileDialog1.Filter = "PowerPoint Presentation|*.pptx"
        rs = SaveFileDialog1.ShowDialog()

        If rs = Windows.Forms.DialogResult.OK Then
            target = Package.Open(SaveFileDialog1.FileName, FileMode.Create, FileAccess.ReadWrite)
            source = Package.Open(OpenFileDialog1.FileName, FileMode.Open, FileAccess.Read)
        End If

        ppt.CreateBasicPresentation(target)

        For Each s As Object In SelectedSlides.Items
            ppt.CopySlide(source, target, s.ToString(), pptHelper.relations.slidePart)
        Next
        target.Flush()
        target.Close()
        MsgBox("Done!")
    End Sub
End Class



Public Class pptHelper

 

    Public Class contents
        Public Shared presentation = "application/vnd.openxmlformats-officedocument.presentationml.presentation.main+xml"
        Public Shared slidemaster = "application/vnd.openxmlformats-officedocument.presentationml.slideMaster+xml"
        Public Shared slideLayout = "application/vnd.openxmlformats-officedocument.presentationml.slideLayout+xml"
        Public Shared slidePart = "application/vnd.openxmlformats-officedocument.presentationml.slide+xml"
        Public Shared themePart = "application/vnd.openxmlformats-officedocument.theme+xml"
    End Class

    Public Class relations
        Public Shared officedocument = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"
        Public Shared slidemaster = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideMaster"
        Public Shared slidelayout = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout"
        Public Shared slidePart = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
        Public Shared themePart = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme"
        Public Shared mainPart = "http://schemas.openxmlformats.org/presentationml/2006/main"
        Public Shared relationship = "http://schemas.openxmlformats.org/officeDocument/2006/relationships"
    End Class



    Dim id As Integer = CInt(New Random().NextDouble * 10000)

    Public Function AddSlide(ByVal pkg As Package, ByVal sldPart As PackagePart) As Boolean
        Dim xmlDoc As New XmlDocument
        Dim rId As String
        Dim xNode As XmlNode
        Dim partUri As Uri


        ' manage namespaces to perform Xml XPath queries.
        Dim nt As New NameTable()
        Dim nsManager As New XmlNamespaceManager(nt)
        nsManager.AddNamespace("p", relations.mainPart)
        nsManager.AddNamespace("r", relations.relationship)
        ' end manage

        Dim slide As PackagePart = pkg.CreatePart(sldPart.Uri, sldPart.ContentType)


        ' connect it with doc part and update document.xml
        Dim doc As PackagePart = pkg.GetPart(New Uri("/ppt/presentation.xml", UriKind.Relative))
        rId = doc.CreateRelationship(slide.Uri, TargetMode.Internal, relations.slidePart).Id

        xmlDoc.Load(doc.GetStream())
        xNode = xmlDoc.CreateNode(XmlNodeType.Element, "p", "sldId", relations.mainPart)
        Dim attrId As XmlAttribute = xmlDoc.CreateAttribute("id")
        attrId.Value = id.ToString()
        Dim attrRId As XmlAttribute = xmlDoc.CreateAttribute("r:id", relations.relationship)
        attrRId.Value = rId
        xNode.Attributes.SetNamedItem(attrId)
        xNode.Attributes.SetNamedItem(attrRId)
        'xNode.Attributes. = "<p:sldId id=" & id.ToString() & " r:id=" & rId & "/>"
        id = id + 1

        xmlDoc.SelectSingleNode("//p:sldIdLst", nsManager).AppendChild(xNode)
        xmlDoc.Save(doc.GetStream(FileMode.Create, FileAccess.ReadWrite))
        ' end connect

        'get slide layout part from the slide
        For Each r As PackageRelationship In sldPart.GetRelationshipsByType(relations.slidelayout)
            Console.WriteLine(r.TargetUri.OriginalString)
            partUri = PackUriHelper.ResolvePartUri(r.SourceUri, r.TargetUri)
            Exit For ' only one layout
        Next
        Dim lyt_src As PackagePart = sldPart.Package.GetPart(partUri)
        Dim layout As PackagePart = Nothing

        Try
            layout = pkg.CreatePart(lyt_src.Uri, lyt_src.ContentType)
            xmlDoc.Load(lyt_src.GetStream())
            xmlDoc.Save(layout.GetStream(FileMode.Create, FileAccess.ReadWrite))
            ' add relationships
            Dim master As PackagePart = pkg.GetPart(New Uri("/ppt/slideMasters/slideMaster1.xml", UriKind.Relative))
            rId = master.CreateRelationship(layout.Uri, TargetMode.Internal, relations.slidelayout).Id
            xNode = xmlDoc.CreateNode(XmlNodeType.Element, "p", "sldLayoutId", relations.mainPart)
            attrId = xmlDoc.CreateAttribute("id")

            ''BUGBUG: id attribute of <sldLayoutId> element needs to be pulled from the source presentation/package
            Dim srcSldMasterPart As PackagePart = sldPart.Package.GetPart(New Uri("/ppt/slideMasters/slideMaster1.xml", UriKind.Relative))
            Dim xmlDocSrcMaster As New XmlDocument
            Dim sSldLayourRId As String = ""
            Dim sldLytPartUri As Uri
            xmlDocSrcMaster.Load(srcSldMasterPart.GetStream())
            For Each r As PackageRelationship In srcSldMasterPart.GetRelationshipsByType(relations.slidelayout)

                Console.WriteLine(r.TargetUri.OriginalString)
                sldLytPartUri = PackUriHelper.ResolvePartUri(r.SourceUri, r.TargetUri)
                If Uri.Compare(sldLytPartUri, partUri, UriComponents.Path, UriFormat.Unescaped, StringComparison.CurrentCulture) = 0 Then
                    sSldLayourRId = r.Id
                    Exit For
                End If

            Next

            Dim xmlNodeSrcLayoutId As XmlNode = xmlDocSrcMaster.SelectSingleNode("//p:sldLayoutIdLst/p:sldLayoutId[@r:id='" & sSldLayourRId & "']", nsManager)

            Dim sSlideLayoutId As String = xmlNodeSrcLayoutId.Attributes.GetNamedItem("id").Value
            attrId.Value = sSlideLayoutId
            attrRId = xmlDoc.CreateAttribute("r:id", relations.relationship)
            attrRId.Value = rId
            xNode.Attributes.SetNamedItem(attrId)
            xNode.Attributes.SetNamedItem(attrRId)
            'xNode.Value = "<p:sldLayoutId id=" & id.ToString & " r:id=" & rId & "/>"
            id = id + 1

            layout.CreateRelationship(master.Uri, TargetMode.Internal, relations.slidemaster)



            xmlDoc.Load(master.GetStream())
            xmlDoc.SelectSingleNode("//p:sldLayoutIdLst", nsManager).AppendChild(xNode)
            xmlDoc.Save(master.GetStream(FileMode.Create, FileAccess.ReadWrite))
            ' end add


        Catch ex As Exception
            layout = pkg.GetPart(lyt_src.Uri)
        End Try

        'end get
        slide.CreateRelationship(layout.Uri, TargetMode.Internal, relations.slidelayout)

        xmlDoc.Load(sldPart.GetStream())
        xmlDoc.Save(slide.GetStream(FileMode.Create, FileAccess.ReadWrite))
    End Function


    Public Function PullSlide(ByRef pkg As Package, ByVal uri As Uri, ByVal relationship As String) As PackagePart
        Dim p As PackagePart = pkg.GetPart(uri)
        Return p
    End Function

    Public Function CopySlide(ByRef sourcePkg As Package, ByRef tgtPkg As Package, ByVal sourceSlide As String, ByVal relationship As String) As Boolean
        Dim sourceUri As Uri = GetUriByTitle(sourcePkg, sourceSlide)
        Dim p As PackagePart = PullSlide(sourcePkg, sourceUri, relationship)
        Return AddSlide(tgtPkg, p)
    End Function
    Public Sub CreateBasicPresentation(ByRef p As Package)
        Dim xmlDoc As New XmlDocument
        xmlDoc.LoadXml(My.Resources.presentation)

        Dim docUri As Uri = PackUriHelper.CreatePartUri(New Uri("ppt/presentation.xml", UriKind.Relative))
        Dim docPart As PackagePart = p.CreatePart(docUri, contents.presentation)
        p.CreateRelationship(docPart.Uri, TargetMode.Internal, relations.officedocument)

        xmlDoc.Save(docPart.GetStream(FileMode.Create, FileAccess.ReadWrite))

        Dim themeUri As Uri = PackUriHelper.CreatePartUri(New Uri("ppt/theme/theme1.xml", UriKind.Relative))
        Dim themePart As PackagePart = p.CreatePart(themeUri, contents.themePart)
        docPart.CreateRelationship(themePart.Uri, TargetMode.Internal, relations.themePart)

        xmlDoc.LoadXml(My.Resources.theme1)
        xmlDoc.Save(themePart.GetStream(FileMode.Create, FileAccess.ReadWrite))


        Dim slideMasterUri As Uri = PackUriHelper.CreatePartUri(New Uri("/ppt/slidemasters/slidemaster1.xml", UriKind.Relative))
        Dim slideMasterPart As PackagePart = p.CreatePart(slideMasterUri, contents.slidemaster)
        docPart.CreateRelationship(slideMasterPart.Uri, TargetMode.Internal, relations.slidemaster, "rId1")

        xmlDoc.LoadXml(My.Resources.slideMaster1)

        slideMasterPart.CreateRelationship(themePart.Uri, TargetMode.Internal, relations.themePart)
        xmlDoc.Save(slideMasterPart.GetStream(FileMode.Create, FileAccess.ReadWrite))
    End Sub

    Public Function GetSlideTitles(ByVal fileName As String) As List(Of String)
        ' Return a generic list containing all the slide titles.        
        ' Fill this collection with a list of all the titles
        ' of all the slides in the requested slide deck.
        Dim titles As New List(Of String)
        Dim documentPart As PackagePart = Nothing
        Dim documentUri As Uri = Nothing

        Using pptPackage As Package = Package.Open(fileName, FileMode.Open, FileAccess.Read)
            ' Get the main document part (presentation.xml).
            For Each relationship As PackageRelationship In pptPackage.GetRelationshipsByType(relations.officedocument)
                documentUri = PackUriHelper.ResolvePartUri(New Uri("/", UriKind.Relative), relationship.TargetUri)
                documentPart = pptPackage.GetPart(documentUri)

                ' There's only one document part. Get out now.
                Exit For
            Next

            ' Manage namespaces to perform Xml XPath queries.
            Dim nt As New NameTable()
            Dim nsManager As New XmlNamespaceManager(nt)
            nsManager.AddNamespace("p", relations.mainPart)

            '  Iterate through the slides and extract the title string from each.
            Dim xDoc As New XmlDocument(nt)
            xDoc.Load(documentPart.GetStream())

            Dim sheetNodes As XmlNodeList = xDoc.SelectNodes("//p:sldIdLst/p:sldId", nsManager)
            If sheetNodes IsNot Nothing Then
                Dim relAttr As XmlAttribute = Nothing
                Dim sheetRelationship As PackageRelationship = Nothing
                Dim sheetPart As PackagePart = Nothing
                Dim sheetUri As Uri = Nothing
                Dim sheetDoc As XmlDocument = Nothing
                Dim titleNode As XmlNode = Nothing

                ' Look at each sheet node, retrieving the relationship id.
                For Each xNode As XmlNode In sheetNodes
                    relAttr = xNode.Attributes("r:id")
                    If relAttr IsNot Nothing Then
                        ' Retrieve the PackageRelationship object for the sheet:
                        sheetRelationship = documentPart.GetRelationship(relAttr.Value)
                        If sheetRelationship IsNot Nothing Then
                            sheetUri = PackUriHelper.ResolvePartUri(documentUri, sheetRelationship.TargetUri)
                            sheetPart = pptPackage.GetPart(sheetUri)
                            If sheetPart IsNot Nothing Then
                                ' You've got a reference to the sheet. Now load its contents and
                                ' find the title.
                                sheetDoc = New XmlDocument(nt)
                                sheetDoc.Load(sheetPart.GetStream())

                                titleNode = sheetDoc.SelectSingleNode("//p:sp//p:ph[@type='title' or @type='ctrTitle']", nsManager)
                                If titleNode IsNot Nothing Then
                                    titles.Add(titleNode.ParentNode.ParentNode.ParentNode.InnerText)
                                End If
                            End If
                        End If
                    End If
                Next
            End If
        End Using
        Return titles
    End Function

    Public Function GetUriByTitle(ByRef pptPackage As Package, ByVal slideTitle As String) As Uri
        ' Given a slide document and a slide title, retrieve the 0-based index of the 
        ' first slide with a matching title. Return -1 if the title isn't found.

        ' Note: This code assumes that the first text found is the title.
        ' Also note that if the title contains more than one font,
        ' or is in any way anything other than plain text, PowerPoint
        ' breaks it up into multiple elements. This code won't find a match
        ' in that case.


        Dim returnValue As Uri
        Dim documentPart As PackagePart = Nothing

        'Using pptPackage As Package = package
        ' Get the main document part (presentation.xml).
        For Each relationship As PackageRelationship In pptPackage.GetRelationshipsByType(relations.officedocument)
            Dim documentUri As Uri = PackUriHelper.ResolvePartUri(New Uri("/", UriKind.Relative), relationship.TargetUri)
            documentPart = pptPackage.GetPart(documentUri)
            ' There is only one document.
            Exit For
        Next

        ' Manage namespaces to perform Xml XPath queries.
        Dim nt As New NameTable()
        Dim nsManager As New XmlNamespaceManager(nt)
        nsManager.AddNamespace("p", relations.mainPart)
        nsManager.AddNamespace("r", relations.relationship)

        ' Get the contents of the presentation part.
        Dim presentationDoc As New XmlDocument(nt)
        presentationDoc.Load(documentPart.GetStream())

        '  Iterate through the slides and extract the title string from each.
        Dim slidePart As PackagePart = Nothing
        Dim slideUri As Uri = Nothing

        ' Select each slide document part (slides/slideX.xml)
        ' via relationship with document part.
        For Each relation As PackageRelationship In documentPart.GetRelationshipsByType(relations.slidePart)
            slideUri = PackUriHelper.ResolvePartUri(documentPart.Uri, relation.TargetUri)
            slidePart = pptPackage.GetPart(slideUri)

            ' Get the slide part from the package.
            Dim doc As XmlDocument = New XmlDocument(nt)

            ' Load the slide contents:
            doc.Load(slidePart.GetStream())

            ' Locate the slide title using XPath.
            Dim titleNode As XmlNode = doc.SelectSingleNode("//p:sp//p:ph[@type='title' or @type='ctrTitle']", nsManager)
            If titleNode IsNot Nothing Then
                ' Perform a case-insensitive comparison.
                Dim titleText As String = titleNode.ParentNode.ParentNode.ParentNode.InnerText
                If String.Compare(titleText, slideTitle, True) = 0 Then
                    ' You've found the slide part with a matching title.
                    ' Get the relationship ID, and find the corresponding item in the 
                    ' document part:
                    Dim searchString As String = String.Format("//p:sldIdLst/p:sldId[@r:id='{0}']", relation.Id)
                    Dim node As XmlNode = presentationDoc.SelectSingleNode(searchString, nsManager)
                    If node IsNot Nothing Then
                        ' Retrieve the index of the selected node.
                        ' To do that, count the number of preceding
                        ' nodes by retrieving a reference to those nodes.
                        returnValue = slidePart.Uri
                    End If

                    ' Only retrieve information about the first slide that matches the specified title.
                    Exit For
                End If
            End If
        Next
        'End Using
        Return returnValue
    End Function
    Public Function GetUriByTitle(ByVal fileName As String, ByVal slideTitle As String) As String
        ' Given a slide document and a slide title, retrieve the 0-based index of the 
        ' first slide with a matching title. Return -1 if the title isn't found.

        ' Note: This code assumes that the first text found is the title.
        ' Also note that if the title contains more than one font,
        ' or is in any way anything other than plain text, PowerPoint
        ' breaks it up into multiple elements. This code won't find a match
        ' in that case.

        Dim returnValue As String = ""
        Dim documentPart As PackagePart = Nothing

        Using pptPackage As Package = Package.Open(fileName, FileMode.Open, FileAccess.ReadWrite)
            ' Get the main document part (presentation.xml).
            GetUriByTitle(pptPackage, slideTitle)

        End Using
        Return returnValue
    End Function

End Class