Looking for some help on updating a VBA Script that completes the following (basic algorithm):
Excel Template with formulas and macros creates a custom report consisting of approximately 30 charts
Macro called “CreatePowerPointPresentation” is used to transfer these charts into a specific PowerPoint template in specific format
The macros uses the slides contained in the template to create the first 6 slides
The macro then adds slides (transitions and content slides)
Note: This macro was actually created based on a feedback from this forum
This macro works great in Windows 7 with Office 2013, but generates errors in Windows 10, Office 2016 after slide 8 is created, randomly during one of the paste chart actions, but never gets past slide 10 of a 17-slide deck.
Errors:
Runtime Error '-2147188160 (80048240)
Method 'PasteSpecial'of object 'Shapes' failed.
Or
Runtime Error '-2147023170 (800706be)':
Automation Error
The Remote procedure call failed.
I'm not sure if this is an object issue or some other piece that I'm missing.
Code below:
Sub CreatePowerPointPresentation()
'=========================================================================
'Create PowerPoint Presentation
'Assigned to Index Tab
'==========================================================================
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim CHT As Excel.ChartObject
Dim fmt As String
Dim hgt As String
Dim wth As String
‘this code allows for the user to select whether to paste the charts as Excel Charts or PNG Formatted images.
Sheets("Index").Select
If Range("AB7").Value = "Excel Charts" Then
fmt = ppPasteDefault
Else
fmt = ppPastePNG
End If
'Establishes the global height and width of the graphics or charts pasted from Excel
hgt = 280
wth = 710
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.EnableEvents = True
Application.ScreenUpdating = True
'Apply Template & Create Title Slide 1
newPowerPoint.ActivePresentation.ApplyTemplate Application.DefaultFilePath & "\file.potx"
'Set presentation to be 16x9
'AppActivate ("Microsoft PowerPoint")
With newPowerPoint.ActivePresentation.PageSetup
.SlideSize = ppSlideSizeOnScreen16x9
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With
'Create Slides 2-6 these are imported from the template
newPowerPoint.ActivePresentation.Slides.InsertFromFile Application.DefaultFilePath & "\File.potx", 0, 1
'Create Slide 7
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActivePresentation.Slides(7).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(33)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
With newPowerPoint.ActivePresentation.Slides(7)
.Shapes("Title 1").TextFrame.TextRange.Text = "Title1"
End With
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
‘Create Slide 8 – Quad Chart Slide
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActivePresentation.Slides(8).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(13)
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
newPowerPoint.ActivePresentation.Slides(8).Shapes("Title 1").TextFrame.TextRange.Text = "Title 1"
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
'Upper Left
Sheets("Charts").Select
ActiveSheet.ChartObjects("Chart 3").Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345
'Upper Right
Sheets("Charts").Select
ActiveSheet.ChartObjects("Chart 2").Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345
'Lower Left
Sheets("Charts").Select
ActiveSheet.ChartObjects("Chart 4").Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 230
newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 690
‘More slides……
Application.EnableEvents = True
Application.ScreenUpdating = True
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
This sounds like the dreaded code-runaway scenario I have faced in PowerPoint before where it takes more time to copy things to and paste things from the Windows clipboard than the VBA code execution and hence the VBA code runs ahead and fails as a result. To confirm that this is the cause, put some break points on the .Copy, .ViewType and .PasteSpecial lines and see if it still fails for your full slide collection. If not, try adding some DoEvents lines after the .Copy and .ViewType lines and if that doesn't help, inject a Delay of one or two seconds instead of the DoEvents. That will at least confirm if the hypothesis is true or not.
Related
I am trying to create an excel vba macro that loops through each slide in a presentation (the presentation was created with an excel vba macro) and adds specific text to the top of each slide.
Right now, this is what I have but it is throwing an error and I can figure out the set slide_title section and the with section. I think the for loop is correct, but not understanding the "with" section. The "with" section text box characteristics are correct....but the code isn't executing because something is clearly wrong with it.
Sub update_slide_title_text()
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoCTrue
ppt.Presentations.Open ("C:\Users\Existing_Presentation.pptx")
Dim ppres As PowerPoint.Presentation
Set ppres = ppt.ActivePresentation
Dim pslide As PowerPoint.Slide
Dim pshape As PowerPoint.Shape
For Each pslide In ppres.Slides
Dim slide_title As Object
Set slide_title = pslide.Shapes.AddTextbox(1, 34.36292, -2.670787, 900, 90)
With slide_title
.Height = 54
.Left = 34.36292
.Top = 15
.Width = 190
.TextFrame.TextRange.Text = "NEED TO CHANGE THIS TO DIFFERENT TEXT FOR EACH SLIDE"
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Font.Size = 20
.TextFrame.TextRange.Font.Color = RGB(0, 133, 85)
End With
Next
End Sub
(Post updated with entire code, sorry about the beginner mistake)
Newbie to both coding and VBA here and I'm trying to adjust the PlotArea for a Chart in a presentation. I'm running this from Excel.
Creating and populating the Chart goes fine, sizing ChartArea is also no problems and formating all titles etc is also without problems.
When the Chart looks athe way I want it to, is the correct size and at the correct place, I want the PlotArea to be a precise size and in a precise location. Sizing goes well but the position does not work.
Here is the code that I use, Including populating the ChartData with dummy data and adding in a red box to show where I want the PlotArea to sit:
Sub CreateChart()
'Declare Excel Object Variables
Dim pptWorkBook As Excel.Workbook
Dim pptWorkSheet As Excel.Worksheet
'Declare PowerPoint Object Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTChart As PowerPoint.Chart
Dim PPTChartData As PowerPoint.ChartData
Dim SldHeight, SldWidth As Integer
Dim ChrHeight, ChrWidth As Single
Dim PlotHeight, PlotWidth As Double
'Declare Excel Object Variable
Dim ExcRange As Range
'Create a new instance of Powerpoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation within the Application
Set PPTPres = PPTApp.Presentations.Add
'Disable Snap-To-Grid
PPTPres.SnapToGrid = msoFalse
'Create a new slide within the Presentation
Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)
'Find out size (points) of Slide
SldHeight = PPTPres.PageSetup.SlideHeight
SldWidth = PPTPres.PageSetup.SlideWidth
'Calculate Chart and Plot Size
ChrWidth = 954
ChrHeight = 525 - 106
PlotWidth = 866 - 95
PlotHeight = 437 - 106 - 20
'No screen updates
Application.ScreenUpdating = False
'Create a new Chart within the Slide, give it proper size
Set PPTShape = PPTSlide.Shapes.AddChart2(-1, xlColumnClustered, 0, 106, ChrWidth, ChrHeight, True)
'Minimize ChartData
PPTShape.Chart.ChartData.Workbook.Application.WindowState = -4140
'Set chartdata
Set PPTChartData = PPTShape.Chart.ChartData
'Set Workbook object reference
Set pptWorkBook = PPTChartData.Workbook
'Set Worksheet object reference
Set pptWorkSheet = pptWorkBook.Worksheets(1)
'Add Data
pptWorkSheet.ListObjects("Table1").Resize pptWorkSheet.Range("A1:B5")
pptWorkSheet.Range("b1").Value = "Items"
pptWorkSheet.Range("a2").Value = "Bikes"
pptWorkSheet.Range("a3").Value = "Accessories"
pptWorkSheet.Range("a4").Value = "Repairs"
pptWorkSheet.Range("a5").Value = "Clothing"
pptWorkSheet.Range("b2").Value = "1000"
pptWorkSheet.Range("b3").Value = "2500"
pptWorkSheet.Range("b4").Value = "4000"
pptWorkSheet.Range("b5").Value = "3000"
'Apply Style
With PPTShape.Chart
.ChartStyle = 4
End With
'Remove title
With PPTShape.Chart
.HasTitle = False
End With
'Format legend
With PPTShape.Chart
.HasLegend = True
.Legend.Position = xlLegendPositionTop
.Legend.Top = 0
End With
'Add axis title
With PPTShape.Chart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Dollars"
End With
'Remove gridlines
With PPTShape.Chart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
'Add data labels
PPTShape.Chart.ApplyDataLabels
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideLeft = 95
.InsideTop = 20
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
End With
'Adding a red textbox with the same dimensions and position as the PlotArea
With PPTShape.Chart.Shapes.AddTextbox(msoTextOrientationDownward, 95, 20, PlotWidth, PlotHeight)
.Line.Weight = 2
.Line.DashStyle = msoLineLongDash
.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
'Quit
Set pptWorkSheet = Nothing
pptWorkBook.Application.Quit
Set pptWorkBook = Nothing
Set PPTChartData = Nothing
Set PPTChart = Nothing
'Screen updates
Application.ScreenUpdating = True
End Sub
Below you can see the result with dummy data. The red box is correct, the PlotArea is the right size but not in the right position. Am I misunderstanding something regarding the InsideLeft vs Left properties? I've been stuck here for hours now and I am not making any progress. A theory a colleague and I have is that the PlotArea is doing a Snap-To to something that can't be seen.
Any help is appreciated!
UPDATE:
I changed the order of positioning and sizing of the PlotArea and it improved.
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95
.InsideTop = 20
End With
The offset from the red box seems consistent and I'm sure it is a small thing I am missing somewhere. See attached image of the new result below.
UPDATE 2:
Here is how I solved this. I'm not entirely sure it is correct logic, but it works at least.
I need to offset the PlotArea by 3.9 points. This seems to involve spacing for TickMarks. My assumption here is that the PlotArea position (.InsideTop and .InsideLeft etc) include TickMark width and height but lacks the means to adjust for this. My workaround looks like this:
'Set the TickMark offset constant
offSet = 3.9
'Set PlotArea position and size
With theShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95 - offSet
.InsideTop = 20 - offSet
End With
As this is mostly guesswork, as far as a solution is concerned, any real answers and not workarounds would still be appreciated.
It seems you're trying to position the chart, not the plot area. Try something like this instead:
'Set PlotArea size and position
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.Left = 60
.Top = -25
End With
I've written a piece of code to copy data from excel and paste it in a powerpoint presentation.
I constantly get the following error:
Selection.ShapeRange : Invalid Request. Nothing Appropriate is
currently selected
Which relates to the following part of the code (where I am pasting the Excel data to the powerpoint slide and determine its position).
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 0
pp.ActiveWindow.Selection.ShapeRange.Left = 0
pp.ActiveWindow.Selection.ShapeRange.Width = 1000
The weird thing is that this code used to work a couple of weeks ago (in excel 2016), but since today (I got downgraded to Excel 2010) it suddenly stopped working..
The full code I am using is as follows:
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange2 As String
Dim TemplatePath As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Start the loop through each worksheet
'Step 3-A: Skip Excel sheets 1 till 8
For Each xlwksht In Worksheets
If xlwksht.Index >= 9 Then
'Step 3-B: Count slides and add new blank slide as next available slide number
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 4: Copy the Content section from Excel
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 5: Paste the Content and adjust its position
'Step 5-A: Determine the Path of the Template and apply it to the Powerpoint presentation
PPPres.ApplyTemplate (TemplatePath & "\Template.potx")
'Step 5-B: Determine the PasteType
pastetype = xlwksht.Range("C1").Value 'Where C1 = "Image" for all images and tables
PasteWidth = xlwksht.Range("D1").Value 'Where D1 = "Title" then picture will fill whole screen
'Step 5-C: Based on the Pastetype paste the content in the presentation
If pastetype = "Image" Then
If PasteWidth = "Title" Then
'Step 5-C-1 Format only for Title Page
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 0
pp.ActiveWindow.Selection.ShapeRange.Left = 0
pp.ActiveWindow.Selection.ShapeRange.Width = 1000
Else
'Step 5-C-2 Format for Images
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 95
pp.ActiveWindow.Selection.ShapeRange.Left = 20
pp.ActiveWindow.Selection.ShapeRange.Width = 300
End If
Else
'Step 5-C-3 Format for Normal tables
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Top = 95
pp.ActiveWindow.Selection.ShapeRange.Left = 20
End If
This may or may not be the answer but plugging the suggestion in here will make it a whole lot more legible than including it as a comment:
Instead of this:
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 0
pp.ActiveWindow.Selection.ShapeRange.Left = 0
pp.ActiveWindow.Selection.ShapeRange.Width = 1000
Try this:
With PPSlide.Shapes.PasteSpecial DataType:=2
.Top = 0
.Left = 0
.Width = 1000
End With
I am trying to automate making PowerPoints so I can avoid making 50 per month. I have my code set up so it goes into my folder and opens all the necessary powerpoints. While it is opening the powerpoints, it filters my pivot table, copies, and pastes into the correct file.
However - when I run the Macro - it skips the first market
ex: when the macro is run - this is my result
Market1 Pivot pastes to no where
Market2 pivot pastes to Powerpoint 1 & Powerpoint 2
Market3 Pivot pastes to Powerpoint 3
I am assuming it has something to do with my "On Error Resume Next" line but unsure how to fix this.
Here is my code:
'Open Powerpoints
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
market = Array("market1", "market2", "market3")
For i = 0 To UBound(market)
'open Powerpoints
Set pptpres = pptapp.Presentations.Open("Powerpoint Folders")
Set pptslide = pptpres.Slides(7)
'update pivot tables
Application.ScreenUpdating = False
ws1.Activate
Set Tradepivot = ws1.PivotTables("PivotTable1")
With Tradepivot.PivotFields("Market")
On Error Resume Next
For z = (0 - 1) To (.PivotItems.Count)
.PivotItems(.PivotItems(z).Name).Visible = False
.PivotItems((market(i)) & " Market").Visible = True
Tradepivot.TableRange1.copy
Next z
pptslide.Shapes.PasteSpecial DataType:=ppPasteOLEObject
pptapp.CommandBars.ExecuteMso ("PasteSourceFormatting")
End With
Next i
Try the section of code below, see if it helps you:
Dim PvtFld As PivotField
Dim PvtItm As PivotItem
With Tradepivot
Set PvtFld = .PivotFields("Market")
PvtFld.ClearAllFilters
For Each PvtItm In PvtFld.PivotItems
If PvtItm.Name = market(i) Then
PvtItm.Visible = True
Else
PvtItm.Visible = False
End If
Next PvtItm
Tradepivot.TableRange1.Copy
pptslide.Shapes.PasteSpecial DataType:=ppPasteOLEObject
pptapp.CommandBars.ExecuteMso ("PasteSourceFormatting")
End With
I am trying to mass-generate a series of PowerPoint presentations. My slide would contain two elements, both created and copied from Excel. I am using Office 2010.
The first element is a SmartArt graphic which is smoothly done. The second one is a few cells that I would like to copy as a Table object (instead of a linked image). After wasting a few hours with "Shapes", I found this, but I cannot manipulate its height and width after pasting.
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Then, when I tried to save the presentation using the following, I realised only the SmartArt is saved; the pasted table is not saved even though the saveAs command occured after the paste.
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPPres.SaveAs saveName, ppSaveAsDefault
PPPres.Close
More bizarrely, I found that when I added a msgbox command for debugging above between paste and save, the table is saved correctly. However, I am trying to mass produce these files and cannot sit down to close each message box.
My questions:
1. How can I change the table's height/width/alignment after pasting?
2. How can I save my file with the table in it?
EDITED, my current code
Sub copyAllToPpt()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPName, xlName As String
xlName = ActiveWorkbook.Name
Dim saveName As String
Workbooks(xlName).Activate
Dim y As Integer
y = ActiveCell.Row
saveName = ActiveSheet.Cells(y, "B").Value & "-" & ActiveSheet.Cells(y, "A").Value & " Stats"
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
PPName = PPPres.Name
PPApp.ActiveWindow.ViewType = ppViewSlide
Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
createSmartArtGraphicThenCopy
PPSlide.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Height = 288
PPApp.ActiveWindow.Selection.ShapeRange.Width = 641
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
PPApp.ActiveWindow.Selection.Unselect
'Macro is working as expected up to here
Workbooks(xlName).Activate
createTable
'Table is copied in subroutine
PPApp.Activate
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Application.Wait (Now + TimeValue("0:00:05"))
'Tried the Wait() to no avail.
DoEvents: DoEvents: DoEvents
PPApp.ActivePresentation.SaveAs saveName, ppSaveAsDefault
PPApp.ActivePresentation.Close
End Sub
This works when I run it from within PPT; you'll need to adapt it by adding references to the PPT application object, etc:
Dim oSh As Object
Dim oSl As Object
Dim x As Long
x = 1 ' or whatever slide you want to work with
Set oSl = ActivePresentation.Slides(x)
CommandBars.ExecuteMso ("PasteSourceFormatting")
DoEvents: DoEvents: DoEvents
Set oSh = oSl.Shapes(oSl.Shapes.Count)
oSh.Left = 0
' etc
Without the DoEvents statements, it fails, in exactly the same way as your save problem fails. Unless you give PPT a few cycles to deal with the newly pasted shape, it thinks that it's not there.