I would like to apply the layout to existing slides in ppt. Below coding is creating new sides and applying the layout. Can someone please assist me on this. I dont want to create new slide. I just want to apply layout to existing slides.
Set ppt = CreateObject("PowerPoint.Application")
Set myPres = ppt.Presentations.Open(pptName)
For i = 1 To 10
Set slds = myPres.Slides
Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
For Each oLayout In myPres.Designs("Office Theme").SlideMaster.CustomLayouts
If oLayout.Name = "Title and Content" Then
sld.CustomLayout = oLayout
Exit For
End If
Next
Next i
Set ppt = CreateObject("PowerPoint.Application")
Set myPres = ppt.Presentations.Open(pptName)
'For i = 1 To 10
' Set slds = myPres.Slides
' Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
For each sld in myPres.Slides
For Each oLayout In myPres.Designs("Office Theme").SlideMaster.CustomLayouts
If oLayout.Name = "Title and Content" Then
sld.CustomLayout = oLayout
Exit For
End If
Next
'Next i
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
I have an Excel with Macro which should:
toggle to active PPT
select slide "X" and delete graphs
Go to Tab "X" in excel
grab new Graph
Paste onto the "X" slide
repeat 5 times
here is the code I've compiled so far:
Dim PPT As Object
Dim rng As Object
Dim rng1 As Object
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim ActivePresentation As Object
'Copy Range from Excel
Set rng = Sheet3.ChartObjects("Chart 6")
Set rng1 = Sheet3.ChartObjects("Chart 7")
Set rng2 = Sheet3.ChartObjects("Chart 8")
Set PPT = CreateObject("PowerPoint.Application")
With PPT
.Visible = True
.WindowState = 1
.Activate
End With
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Set myPresentation = PowerPointApp.Presentations.Add *this should not say add as it adds a slide,but no luck with any other commands*
' PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) *this should not say add as it adds a slide,but no luck with any other commands*
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 20
myShape.Top = 152
rng1.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 486
myShape.Top = 152
Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly
etc..
End Sub
this creates a new PPT and add slides to the new ppt, have tried a numerous helps and web pages but unfortunately was not able to find a piece of code which would tackle this problem. Would be much appreciated if you could advise or point me to the correct help or tutorial which would be possible to solve this issue with.
code is based on the following assumptions from your statement
Already have a presentation open
want to copy two or three charts from each sheets, starting from Sheets(2) to Sheets(5) to slides 2 to 5 respectively as shown below.
Code may be modified to your requirement
Sub AddtoOpenPPT()
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShape As PowerPoint.Shape
Dim Fname As String
Dim sld As Long, i As Long, ObjNo As Long
Dim Rng(0 To 9) As Object
Set Rng(0) = Sheet3.ChartObjects("Chart 6")
Set Rng(1) = Sheet3.ChartObjects("Chart 7")
Set Rng(2) = Sheet3.ChartObjects("Chart 8")
Set Rng(3) = Sheet3.ChartObjects("Chart 5")
Set Rng(4) = Sheet1.Range("b4:j14")
Set Rng(5) = Sheet1.Range("A4:l4", "A15:j19")
Set Rng(6) = Sheet4.ChartObjects("Chart 13")
Set Rng(7) = Sheet4.ChartObjects("Chart 15")
Set Rng(8) = Sheet4.ChartObjects("Chart 17")
Set Rng(9) = Sheet4.ChartObjects("Chart 19")
Set PPT = GetObject(class:="PowerPoint.Application")
Set myPresentation = PPT.ActivePresentation
ObjNo = 0
For sld = 2 To 5
Set mySlide = myPresentation.Slides(sld)
For i = mySlide.Shapes.Count To 1 Step -1
mySlide.Shapes(i).Delete
Next
For i = 1 To 3
Rng(ObjNo).Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = IIf(i Mod 2 = 1, 20, 486)
myShape.Top = IIf(i < 3, 50, 200)
ObjNo = ObjNo + 1
If ObjNo > UBound(Rng) Then Exit For
Next
If ObjNo > UBound(Rng) Then Exit For
Next sld
End Sub
This is my code for exporting Contents from Excel to PowerPoint. My Problem is I have only one slide in the presentation. As the criteria is met, VBA should automatically increase the slides and populate it. The slides should be of the same layout. After every IF and Else Loop I Need to add a new slide for the next Iteration. Using this code I get an error that Active X component cant create object. Any help ?
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim pptSlide As PowerPoint.Slide
Dim pptLayout As CustomLayout
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\asehgal\Desktop\OPL\Presentation1.pptx"
On Error Resume Next
Set oPPTApp = GetObject(, "PowerPoint.Application")
If oPPTApp Is Nothing Then
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = True 'msoTrue
End If
On Error GoTo 0
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 1
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table 1")
On Error Resume Next
If oPPTApp.Windows.Count > 0 Then
Set oPPTFile = oPPTApp.ActivePresentation
Set pptSlide = oPPTFile.Slides(oPPTApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Else
Set oPPTFile = oPPTApp.Presentations.Add
Set pptSlide = oPPTFile.Slides.AddSlide(1, ppLayout)
End If
On Error GoTo 0
Do
'if topics are same
If (arrThema(p, 0) = arrThema(p + 1, 0)) Then
With oPPTShape.Table
.cell(1, 1).Shape.TextFrame.TextRange.text = arrThema(p, 0)
'if true Adda new slide here for the next iteration
End With
'If subtopics are also same
If (arrThema(p, 1) = arrThema(p + 1, 1)) Then
Else 'if subtopics are different
With oPPTShape.Table
.cell(2, 1).Shape.TextFrame.TextRange.text = arrThema(p, 1)
.cell(3, 2).Shape.TextFrame.TextRange.text = Beschreibung(p)
'if true Add a new slide here for the next iteration
End With
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table 1")
With oPPTShape.Table
.cell(2, 1).Shape.TextFrame.TextRange.text = arrThema(p + 1, 1)
.cell(3, 2).Shape.TextFrame.TextRange.text = Beschreibung(p + 1)
'if true Adda new slide here for the next iteration
End With
' MsgBox "Description : " & Beschreibung(p)
End If
Else
'add a new slide here and add the details there
With oPPTShape.Table
.cell(1, 1).Shape.TextFrame.TextRange.text = arrThema(p, 0)
.cell(2, 1).Shape.TextFrame.TextRange.text = arrThema(p, 1)
.cell(3, 2).Shape.TextFrame.TextRange.text = Beschreibung(p)
'if true Adda new slide here for the next iteration
'code for adding a new slide which does not work
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
Set pptSlide = ActivePresentation.Slides.AddSlide(2, pptLayout)
End With
End If
p = p + 1
Loop Until p = noThema
Use this code whever you need to insert a new slide, it will add the slide to the end of the presentation and apply your custom layout
Set pptSlide = oPPTApp.Slides.AddSlide(oPPTApp.Slides.Count + 1, pptLayout)
Edit
Apologies, I couldn't test it myself. Try the edited code above
i am trying to populate some text fields in a powerpoint file using the below code:
Private Sub OpenPPT_Click()
Dim pptPres As PowerPoint.Presentation
Dim pptApp As PowerPoint.Application
Dim currentSlide As Slide
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Open("C:\Users\Magda\Desktop\TestReport.pptx")
Set currentSlide = pptPres.Slides(pptPres.Slides.Count)
'Slide 1
currentSlide.Shapes("HomeTitle1").TextFrame.TextRange.Text = "This is the title"
currentSlide.Shapes("HomeTitle2").TextFrame.TextRange.Text = "This is the subtitle"
'Slide 2
currentSlide.Shapes("MainTitle1").TextFrame.TextRange.Text = "This is the title"
currentSlide.Shapes("Contents1").TextFrame.TextRange.Text = "Section1"
currentSlide.Shapes("Contents2").TextFrame.TextRange.Text = "Section2"
currentSlide.Shapes("Contents3").TextFrame.TextRange.Text = "Section3"
currentSlide.Shapes("Contents4").TextFrame.TextRange.Text = "Section4"
'Slide 3
currentSlide.Shapes("MainTitle2").TextFrame.TextRange.Text = "Section1"
End Sub
My issue is that this code only seems to set text in slide 3 (final slide in PPT). How do i loop through the slides so that each gets populated?
The following code works for me, looping through each slide (Access 2010 manipulating PowerPoint 2010):
Option Compare Database
Option Explicit
Sub pptTest()
Dim pptApp As New PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim currentSlide As Slide
Dim i As Long
Set pptPres = pptApp.Presentations.Open("C:\Users\Gord\Desktop\TestReport.pptx")
For i = 1 To pptPres.Slides.Count
Set currentSlide = pptPres.Slides(i)
Debug.Print currentSlide.Name
Next
Set currentSlide = Nothing
pptPres.Close
Set pptPres = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub
Of course, if you need to do slightly different things to each slide you could just do
Set currentSlide = pptPres.Slides(1)
' do stuff for Slide 1
Set currentSlide = pptPres.Slides(2)
' do stuff for Slide 2
' and so on
I have a ppt which is generated every week. I have created a vbscript for updating the linked chart.. but i couldn't find how to identify the excel sheet which i have used for creating the table in the ppt...
Dim pptChart
Dim pptChartData
Dim xlWorkbook
Dim sld
Dim shp
'opent the ppt
strPresPath = "C:\oldpptlocation.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = True
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each sld In oPPTFile.Slides 'ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Set pptChart = shp.Chart
Set pptChartData = pptChart.ChartData
pptChartData.Activate
Set pptWorkbook = pptChartData.Workbook
On Error Resume Next
'update first link
pptWorkbook.UpdateLink pptWorkbook.LinkSources(1)
'On Error GoTo 0
pptChart.Refresh
pptWorkbook.Close True
End If
Next
Next
oPPTFile.SaveAs ("C:\updated_ppt.pptx")
oPPTFile.Close
oPPTApp.Quit
Set pptWorkbook = Nothing
Set pptChartData = Nothing
Set pptChart = Nothing
You're currently checking each shape for a chart, you need to add an ElseIf to test whether the shape .HasTable.
If shp.HasChart Then
'your code to update chart
ElseIf shp.HasTable Then
'your code to update table
End If