Creating a new presentation by pulling slides from a presentation
You’ll remember that a few days back I’ve posted a code snippet which demonstrates how to create a PowerPoint presentation from scratch using System.IO.Packaging.
Here is the next part of the same code which is “works on my machine” certified :)
This is a simple WinForms Application which demonstrates how to pull the slides from a presentation and creates a new presentation.
In simplest terms this is what the code is doing -
1. It let’s you browse to a PowerPoint presentation, iterates through all the slides and displays the slide heading (GetSlideTitles)
2. Once you select the slides you want from the presentation, it pulls those slides and associated slide layouts from the presentation. Then it adds the slides to a new presentation. (PullSlide, GetURIFromTitle, AddSlide)
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 = "https://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"
Public Shared slidemaster = "https://schemas.openxmlformats.org/officeDocument/2006/relationships/slideMaster"
Public Shared slidelayout = "https://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout"
Public Shared slidePart = "https://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
Public Shared themePart = "https://schemas.openxmlformats.org/officeDocument/2006/relationships/theme"
Public Shared mainPart = "https://schemas.openxmlformats.org/presentationml/2006/main"
Public Shared relationship = "https://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
Technorati tags: Pranav+Wagh, Microsoft+blogger, Open+XML, OpenXML, Office+2007, Office2007
IceRocket tags: Pranav+Wagh, Microsoft+blogger, Open+XML, OpenXML, Office+2007, Office2007
Not responsible for errors in content, meaning, tact, or judgment. Live and let live. Toes go in first. I didn't do it. Enjoy.