Sub Day1()
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
Set PowerPoint.Slide = 5
objPPT.Visible = True
objPPT.Presentations.Open "C:\Users\Me\Desktop\Macro Test\Day 1.pptx"
End Sub
I want this to open the fifth slide on my PowerPoint presentation.
Your example code is almost right. Just needed to use the right object, and select the slide.
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
objPPT.Presentations.Open("your file")
objPPT.Slides(5).Select
Related
I am trying to add a slide in a Presentation but I am having an error.
Context:
I have a word file that contains more than 200 pages. Each page contains an image (a screenshot). I want to create a PowerPoint document and for each images in the MS Word document; I want to paste the picture in a blank layout slides.
Sub transfert_image_from_WORD_to_PowerPoint()
'I added a Reference Object to this Module (PowerPoint)
'Variable creation
Dim pptPres As PowerPoint.Presentation
Dim pptApp As PowerPoint.Application
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
'add Slides
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Set pptLayout = ActivePresentation.Slides(0).CustomLayout
'Set pptSlide = ActivePresentation.Slides.AddSlide(0, pptLayout)
'Word object creation to contains images.
Dim pic As InlineShape
Dim pslides As Slides
'loop through eanch Picutures in MS Word
For Each pic In ActiveDocument.InlineShapes
pic.Select
Selection.Copy
'Selection.PasteAndFormat wdPasteDefault
Next
End Sub
I have an error in the line Set pptLayout
Not sure why you aer using ActivePresentation when you create a Presentation object. Anyway, here is how you can add a slide. You use the Add method of the CustomeLayouts collection, then you can add a slide
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(1)
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
I'm current using vba to automate the creation of a ppt report. I need to copy charts from excel and paste into ppt. I successfully used the ExecuteMso "PasteExcelChartSourceFormatting" to paste the chart in, which I need to use so I can paste while keeping the source formatting and embedding the workbook, but I keep getting an error after that when my code tries to reposition the chart in ppt.
See code:
Sub Update()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.Presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
ppPres.Slides(1).Shapes(7).Delete
Sheet1.ChartObjects("Chart 24").Chart.ChartArea.Copy
ppPres.Slides(1).Select
DoEvents
ppApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
ppApp.CommandBars.ReleaseFocus
DoEvents
ppPres.Slides(1).Shapes(7).Left = _
(ppPres.PageSetup.SlideWidth / 2) - (ppPres.Slides(1).Shapes(7).Width / 2)
ppPres.Slides(1).Shapes(7).Top = 77
End Sub
I get a run-time error '--2147188160 (80048240)', method 'Item' of object 'Shapes' failed. The debug highlights the last few lines of my code.
Any advice would be greatly appreciated!
I know this is a little late to the game, but I used this post to try and answer the same problem I was having. And I wanted to pay it forward when I found the solution.
Now my code is a little different because I'm creating a new slide for every chart in my excel worksheet, but I too need to keep the source formatting.
Dim PowerPointApp As Object
Dim CurrentSlide As Object
Dim PowerPointDoc As Object
Dim xChart As ChartObject
Dim wb As Workbook
Dim ws As Worksheet
Dim Chart As ChartObject
Dim Sheet As Worksheet
Dim x As Long
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set PowerPointApp = CreateObject("Powerpoint.Application")
Set PowerPointDoc = PowerPointApp.Presentations.Add(msoTrue)
PowerPointApp.Visible = True
For Each Chart In ws.ChartObjects
PowerPointApp.ActivePresentation.Slides.Add
PowerPointApp.ActivePresentation.Slides.count + 1, 12
Set CurrentSlide = PowerPointDoc.Slides(PowerPointDoc.Slides.count)
CurrentSlide.Select
Chart.Copy
PowerPointApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
'**********************************
Do
DoEvents
Loop Until CurrentSlide.Shapes.count > 0
'**********************************
Next Chart
The "Do While Loop" has helped avoid this error. It does take some time for the macro to finish depending on how many charts you have.
Can you try this, slightly different method
Sub Update()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.Presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
Set ppSlide = ppPres.Slides(1)
ppSlide.Shapes(7).Delete
Sheet1.ChartObjects(1).Chart.ChartArea.Copy
ppSlide.Shapes.Paste.Select
With ppPres.Windows(1).Selection.ShapeRange
.Left = (ppPres.PageSetup.SlideWidth / 2) - (.Width / 2)
.Top = 77
End With
End Sub
UPDATE:
I split this into two subs. Can you give this a try
Sub Update()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
Set ppSlide = ppPres.Slides(1)
ppSlide.Shapes(7).Delete
Call CopyAndPasteChart(ppApp, ppSlide)
With ppSlide.Shapes(ppSlide.Shapes.Count)
.Left = (ppPres.PageSetup.SlideWidth / 2) - (.Width / 2)
.Top = -77
End With
ppApp.CommandBars.ReleaseFocus
End Sub
Sub CopyAndPasteChart(ppApp As PowerPoint.Application, ppSlide As PowerPoint.Slide)
Sheet1.ChartObjects(1).Chart.ChartArea.Copy
ppApp.CommandBars.ExecuteMso ("PasteExcelChartSourceFormatting")
End Sub
You could edit the CopyAndPasteChart Sub a bit more if you fancied to make it usable in more situations.
I'm trying to add a silde in existing powerpoint presentation for each chart in opened excel file. VBA keeps throwing errors.
In here pptApp.ActivePresentation.Add I keep getting an error that the Object does not support method
And in here ActiveChart.ChartArea.Copy that the object variable is not set.
Is is as hopeless as it appears?
Option Explicit
#Const EARLYBINDING = False
Sub CopyAndLinkAllChartsToExistingPPT()
#If EARLYBINDING Then
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
#Else
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Const ppLayoutTitle = 1
#End If
Dim workS As Worksheet
Dim chartS As Excel.ChartObjects
Dim workS_Count As Integer
Dim chartS_Count As Integer
Dim W As Integer
Dim C As Integer
'Declaring PPT objects
Set pptApp = GetObject(, "PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add(msoTrue)
Set pptSlide = pptPres.Slides.Add(1, ppLayoutTitle)
'Declaring Excel objects
Set workS = ActiveWorkbook.worksheets(1)
Set chartS = workS.ChartObjects
'Amount of worksheets and charts for the loops
workS_Count = ActiveWorkbook.worksheets.Count
chartS_Count = workS.ChartObjects.Count
'Nested loop for all the worksheets and charts
For W = 1 To workS_Count
For C = 1 To chartS_Count
pptApp.ActivePresentation.Add
pptApp.ActivePresentation.Slides.Count 1, ppLayoutTitle
pptApp.ActiveWindow.View.GotoSlide
pptApp.ActivePresentation.Slides.Count
Set pptSlide = pptApp.ActivePresentation.Slides(pptApp.ActivePresentation.Slides.Count)
chartS.Select
ActiveChart.ChartArea.Copy
'Pasting chart in PowerPoint slide with a data link
pptSlide.Shapes.PasteSpecial link:=msoTrue
Next C
Next W
' Clearing the objects
Set pptApp = Nothing
Set pptPres = Nothing
Set pptSlide = Nothing
Set workS = Nothing
Set chartS = Nothing
End Sub
I think that you got it all wrong there when you are adding slides.
You already created a presentation so you just need to add slides and paste charts right ?
What you are doing in your loop (and wrong) is adding a new presentation for each chart that you need to paste, then a slide to it.
Try to simplify it:
For W = 1 To workS_Count
For C = 1 To chartS_Count
Set pptSlide = pptPres.slides.add(pptPres.slides.count, ppLayoutTitle)
chartS(chartS_Count).Select
ActiveChart.ChartArea.Copy
'Pasting chart in PowerPoint slide with a data link
pptSlide.Shapes.PasteSpecial link:=msoTrue
Next C
Next W
I am trying to create charts and tables in excel and then copy them to slides in powerpoint all through a PowerPoint VBA macro. I have the charts and tables created but I am having an issue with copying and pasting them over. I am not familiar with the syntax to do so. Any help would be greatly appreciated as I am new to PowerPoint VBA.
Sub GenerateVisual()
Dim dlgOpen As FileDialog
Dim folder As String
Dim excelApp As Object
Dim xlWorkBook As Object
Dim xlWorkBook2 As Object
Dim PPT As Presentation
Dim Name1 As String
Dim Name2 As String
Set PPT = ActivePresentation
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True
Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
xlWorkBook.Sheets("MarketSegmentTotals").Activate
xlWorkBook.ActiveSheet.Shapes.AddChart.Select
xlWorkBook.ActiveChart.ChartType = xlColumnClustered
xlWorkBook.ActiveChart.SetSourceData Source:=xlWorkBook.ActiveSheet.Range("MarketSegmentTotals!$A$1:$F$2")
xlWorkBook.ActiveChart.Legend.Delete
xlWorkBook.ActiveChart.SetElement (msoElementChartTitleAboveChart)
xlWorkBook.ActiveChart.SetElement (msoElementDataLabelCenter)
xlWorkBook.ActiveChart.ChartTitle.Text = "DD Ready by Market Segment"
xlWorkBook.ActiveSheet.ListObjects.Add
xlWorkBook.ActiveSheet.ChartObjects(1).Select 'My attempt to copy them over but it doesnt work
PPT.ActiveWindow.View.Paste
End Sub
This sub will get you on your way. It needs some tweaks but this can copy over a range into a PPT:
Public Sub RangeToPresentation(sheetName, NamedRange)
Dim CopyRng As Range
Set CopyRng = Sheets(sheetName).Range(NamedRange)
Dim ppApp As Object
Dim ppPres As Object
Dim PPSlide As Object
If Not TypeName(CopyRng) = "Range" Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, _
"No Range Selected"
Else
Set ppApp = GetObject(, "Powerpoint.Application")
Set ppPres = ppApp.ActivePresentation
ppApp.ActiveWindow.ViewType = ppViewNormal
Dim longSlideCount As Long
' Determine how many slides are in the presentation.
longSlideCount = ppPres.Slides.Count
With ppPres
' Insert a slide at the end of the presentation
Set PPSlide = ppPres.Slides.Add(longSlideCount + 1, ppLayoutBlank)
End With
' Select the last (blank slide)
longSlideCount = ppPres.Slides.Count
ppPres.Slides(longSlideCount).Select
Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
CopyRng.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
' Paste the range
PPSlide.Shapes.Paste.Select
'Set the image to lock the aspect ratio
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue
'Set the image size slightly smaller than width of the PowerPoint Slide
ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10
'Shrink image if outside of slide borders
If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
End If
' Align the pasted range
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End If
End Sub
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