Create PowerPoint slide using Specific background graphics

[Faridwahidi]

Hi,

I am creating power point slide from excel workbook. It working fine but how to add specific background graphics (theme) to a new ppLayout slide. I am pretty sure that it need to be amended here
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly), but no idea how to do that. Can anyone solve it?



'to Copy Charts
cht = Array("Sheet1", "Sheet2")
For i = LBound(cht) To UBound(cht)
Set sht = Sheets(cht(i))
For Each ch In sht.ChartObjects
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
sht.Select
ch.Select
ActiveChart.ChartArea.Copy
mySlide.Select
Set myShapeRange = mySlide.Shapes.PasteSpecial(ppPasteDefault)
myShapeRange.Select
myShapeRange.Left = 28
myShapeRange.Top = 125
myShapeRange.Width = 665
myShapeRange.Height = 400
mySlide.Shapes(1).TextFrame.TextRange.Text = ch.Chart.ChartTitle.Text
Next ch
Next i

[John Wilson]

To apply one of the inbuilt themes the code would look like this for Office 2010 The path will be different for other versions

myPresentation.ApplyTemplate "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Apex.thmx" '32 bit Office on 64 bit windows
OR
myPresentation.ApplyTemplate "C:\Program Files \Microsoft Office\Document Themes 14\Apex.thmx" '64 bit Office or 32 bit with 32 bit windows'

depending on the 32 / 64 bit combination

For a third party theme just change the address.

In the original code you do NOT need to select mySlide or myShaperange.

[Faridwahidi]

Hi John,

The above does not work for me. I am using office 2013, 32-bit.

I have used on the other way around by set theme in default temple file to be opened using VBA and save as on the other name once completed.



Sub PowerPoint_Presentation()
Dim sht As Worksheet, cht, i%, fn$, PPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation, pres As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide, myShapeRange As PowerPoint.ShapeRange
Dim ch As Excel.ChartObject, fname$
fname = ThisWorkbook.Path & "\" & "MyVBA_Presentation"
fn = ThisWorkbook.Path & "\" & "Default template.pptx"


On Error Resume Next
Set PPointApp = GetObject(Class:="PowerPoint.Application")
Err.Clear
If PPointApp Is Nothing Then Set PPointApp = CreateObject(Class:="Powerpoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0


PPointApp.Visible = msoTrue
Set pres = PPointApp.Presentations.Open(fn)
PPointApp.Activate

cht = Array("Sheet1", "Sheet2")
For i = LBound(cht) To UBound(cht)
Set sht = Sheets(cht(i))
For Each ch In sht.ChartObjects
Set mySlide = pres.Slides.Add(1, ppLayoutTitleOnly)
' use Design #1 from pres
mySlide.CustomLayout = pres.Designs(1).SlideMaster.CustomLayouts(3)
sht.Activate
ch.Chart.ChartArea.Copy
Set myShapeRange = mySlide.Shapes.PasteSpecial(ppPasteDefault)
myShapeRange.Left = 28
myShapeRange.Top = 125
myShapeRange.Width = 500
myShapeRange.Height = 300
mySlide.Shapes(2).TextFrame.TextRange.Text = ch.Chart.ChartTitle.Text
mySlide.Shapes(1).Delete
Next ch
Next i

' to Copy Range of Data
Dim Rng1 As Range, Rng2 As Range, Rsht As Worksheet, sh, j%
sh = Array("Sheet3", "Sheet4")
For j = LBound(sh) To UBound(sh)
Set Rsht = Sheets(sh(j))
If Rsht.Name = "Sheet3" Then
Set Rng1 = Rsht.Range("A1:G15")
Set mySlide = pres.Slides.Add(1, ppLayoutTitleOnly)
mySlide.CustomLayout = pres.Designs(1).SlideMaster.CustomLayouts(3)
Rng1.Copy
Set myShapeRange = mySlide.Shapes.PasteSpecial(ppPasteDefault)
myShapeRange.Left = 28
myShapeRange.Top = 125
myShapeRange.Width = 500
mySlide.Shapes(2).TextFrame.TextRange.Text = "BB vs RCB"

ElseIf Rsht.Name = "Sheet4" Then
Set Rng1 = Rsht.Range("A1:I14")
Set mySlide = pres.Slides.Add(1, ppLayoutTitleOnly)
mySlide.CustomLayout = pres.Designs(1).SlideMaster.CustomLayouts(3)
Rng1.Copy
Set myShapeRange = mySlide.Shapes.PasteSpecial(ppPasteDefault)
myShapeRange.Left = 28
myShapeRange.Top = 125
myShapeRange.Width = 500
mySlide.Shapes(2).TextFrame.TextRange.Text = Rsht.Range("A1").Value
Set Rng2 = Rsht.Range("A17:I30")
Set mySlide = pres.Slides.Add(1, ppLayoutTitleOnly)
mySlide.CustomLayout = pres.Designs(1).SlideMaster.CustomLayouts(3)
Rng2.Copy
Set myShapeRange = mySlide.Shapes.PasteSpecial(ppPasteDefault)
myShapeRange.Left = 28
myShapeRange.Top = 125
myShapeRange.Width = 500
mySlide.Shapes(2).TextFrame.TextRange.Text = Rsht.Range("A17").Value
End If
Next j

Application.CutCopyMode = False
PPointApp.Activate
PPointApp.ActivePresentation.SaveAs ThisWorkbook.Path & "\" & "New_Presentation"
Set PPointApp = Nothing
Rsht.Select
MsgBox "Done !"
End Sub