I'm trying to automate the creation of powerpoint decks that i have to produce every month. I'm working in Excel VBA and cant figure out how to copy a range from excel, and paste it into a slide as a table.
Below is the code i have so far:
Sub Open_PowerPoint_Presentation()
Dim objPPT As Object, _
PPTPrez As PowerPoint.Presentation, _
pSlide As PowerPoint.Slide
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set PPTPrez = objPPT.Presentations.Open("file location")
Set pSlide = PPTPrez.Slides(4)
Dim RevenueDetail As Range
Dim RevenueDetailTable As Object
Sheets("Revenue By Type Slide").Activate
Set RevenueDetail = Range("B4:I18")
RevenueDetail.Copy
Set RevenueDetailTable = pSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
With RevenueDetailTable
.Left = 43.99961
.Top = 88.61086
.Width = 471.2827
.Height = 395.2163
End With
End Sub
This works OK but it pastes the excel range as a picture which is not ideal. i'd like to paste it as a table which is what the default paste option does, but then i lose the ability to re-size and re-position it on the slide by the means that i'm currently using. I've been messing with this for awhile and can't seem to get it right.
if i modify
Set RevenueDetailTable = pSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
and change it to
Set RevenueDetailTable = pSlide.Shapes.Paste
it pastes in the format i want but i cant figure out how to reposition and resize. any help would be greatly appreciated.
Fixed it... just needed to add a line "pSlide.Select" to select the slide i'm pasting into prior to pasting, and change .PasteSpecial(ppPasteEnhancedMetafile) to just .Paste...thanks for all help!!!!
Sub Open_PowerPoint_Presentation()
Dim objPPT As Object, _
PPTPrez As PowerPoint.Presentation, _
pSlide As PowerPoint.Slide
Dim RevenueDetail As Range
Dim RevenueDetailTable As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set PPTPrez = objPPT.Presentations.Open("file location")
Set pSlide = PPTPrez.Slides(4)
Set RevenueDetail = Sheets("Revenue By Type Slide").Range("B4:I18")
RevenueDetail.Copy
pSlide.Select 'needed to add this line
Set RevenueDetailTable = pSlide.Shapes.Paste
With RevenueDetailTable
.Left = 43.99961
.Top = 88.61086
.Width = 471.2827
.Height = 395.2163
End With
End Sub
Related
The task is to loop through an Excel workbook with multiple sheets and copy all the charts contained in the workbook into a PowerPoint presentation, one chart per slide and always the same layout.
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
ch.Copy
With pptSlide.Shapes.Paste
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
The code works on my example (2 sheets, 3 charts total) but not if I apply it to the real thing, which is a workbook with 10-15 sheets and 8 charts per sheet. At some (random?) point, the code stops and gives me this error.
Run-time error:
Shapes (unknown member): Invalid request. Clipboard is empty or contains data which may not be pasted here.
I noted that the code crashed earlier, the more objects I put on the slides (which is why I left the text and the box in my example, although not strictly neccessary). Given that and the error message, I assumed the clipboard might not be cleared properly after each loop, so I put in a section to clear the clipboard but it didn't solve the issue.
After the chart is copied, try adding DoEvents and pausing the macro for a few seconds before pasting it into your slide. And the same thing after it's pasted into your slide.
So, for example, first add the following function to pause your code . . .
Sub PauseMacro(ByVal secs As Long)
Dim endTime As Single
endTime = Timer + secs
Do
DoEvents
Loop Until Timer > endTime
End Sub
Then try something like this . . .
ch.Copy
DoEvents
PauseMacro 5 'pause for 5 seconds
With pptSlide.Shapes.Paste
DoEvents
PauseMacro 5 'pause for 5 seconds
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
You may find through testing that you can pause for less than 5 seconds, maybe 3 seconds.
My approach is to split out potentially time-consuming operations into separate functions (see "'' Call as a Function" below). When a function is called, and then has to return, it seems that Excel/VBA/the-little-green-men-running-everything make sure that whatever operation it is waits until the operation is finished (the chart is totally added to the clipboard, the clipboard contents are totally pasted, the shape is totally instantiated, etc.) before continuing.
This also means not necessarily forcing a delay during execution that might not be needed (the Do Until or Loop Until or Wait that is often suggested).
So your code might look like this (caveat: untested)
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = NewSlide(pptPres) '' Call as a Function
ch.Copy
Dim shp As PowerPoint.Shape
Set shp = NewShape(pptSlide) '' Call as a Function
With shp
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = NewBox(pptSlide) '' Call as a Function
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = NewTextBox(pptSlide) '' Call as a Function
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function
Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
Set NewShape = pptSlide.Shapes.Paste
End Function
Function NewBox(pptSlide As PowerPoint.Slide) As Object
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
Set NewTextBox = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
After a recent Office 365 update, my code to copy tables from Excel to Power Point stopped working.
Previous code:
Sub GeneratePresentation()
Dim pptApp As PowerPoint.Application
Dim pptPrez As PowerPoint.Presentation
Dim pSlide As PowerPoint.Slide
Dim objPPT As Object
Dim myRange As Excel.Range
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
MonthNo = Month(Worksheets("inputs").Range("B3"))
MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9)
If MonthData = "" Then
MsgBox "Please update losses"
Else
FilePath = "\\Model\"
Filename = "Template Monthly reports.pptx"
file = FilePath & Filename
Set pptPrez = objPPT.Presentations.Open(file)
Set pptApp = GetObject(Class:="PowerPoint.Application")
Set pptPrez = pptApp.ActivePresentation
'Slide 1 title 1
Set pSlide = pptPrez.Slides(1)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
Set osh = pSlide.Shapes.PasteSpecial(ppPasteDefault)(1)
With osh
.Top = 160
.Left = 135
.Height = 80
.Width = 550
End With
Code continues to paste tables and pictures. then
End if
End sub
I get the following error:
VBA error Run-time '-2147188160 (80048240)': Shapes (unknown member)
I have tried most variants of paste but it only lets me paste pictures or text. I noticed that the VBA refernce library revision seems to have reduced to Microsoft PowerPoint 14.0 Object library when I am fairly sure it was build 15 or 16 before. Would this be the cause?
I have come up with a solution which is to use
'Slide 1 title 1
i = 1
Set pSlide = pptPrez.Slides(i)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
pptPrez.Windows(1).Activate
pptPrez.Windows(1).View.GotoSlide i
pptPrez.Slides(i).Shapes("Title").Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
With pptPrez.Slides(i)
With .Shapes("Title")
.LockAspectRatio = msoFalse
.Top = 160
.Left = 135
.Height = 70
.Width = 550
'.TextFrame.TextRange.Font.Name = "Futura Bold"
'.TextFrame.TextRange.Font.Size = 24
'.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
'.TextFrame.TextRange.ParagraphFormat.WordWrap = msoTrue
End With
End With
For the alternative, I have to create all the tables manually then name them and select them in the code which works, but it seems less consistent and reliable requiring the windows to be active being more to go wrong.
Any ideas how to get the first code working again? I can paste manually still but it seems not using pastespecial. Why would an update remove this ability? I've tried proven code from this forum using this paste function but it won't work either which used to, It's definitely the update as all our computers now have the same issue which I find hard to believe too.
I decided to write an answer instead of a bunch of comments, since I wanted to post my code.
Those Office 365 updates have caught me a time or three. But I don't know what's the problem.
The code fails on PasteSpecial? PasteSpecial is a relative newcomer to PowerPoint VBA, but I thought it was around for Office 14 (2010). The reference to version 14.0 of the PowerPoint library is strange. Can you go to Tools > References and scroll to version 16.0? If so, check that one instead. What version of Office are you using: go to File tab > Account, and find the version number and build number.
Why do you have both CreateObject and GetObject. For PowerPoint, you only need to do this once, using CreateObject. If PowerPoint is running, CreateObject returns the running instance; if not, it returns a new instance. Probably not important, but it adds clutter. Move CreateObject up to where GetObject is, and change objPPT to pptApp (since you don't need both).
Also, you've used three variables which are not declared. Declare MonthNo and MonthData as Variant and osh as PowerPoint.Shape (actually, in my code I renamed it pptShape and pSlide to pptSlide for consistency).
With the additional modification to use the active presentation instead of opening one at a given path and file name, your code works fine for me. I'm running Version 1711, Build 8711.2037, for what it's worth.
And here's the code that ran fine for me.
Sub GeneratePresentation()
Dim pptApp As PowerPoint.Application
Dim pptPrez As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim myRange As Excel.Range
Dim pptShape As PowerPoint.Shape
Dim MonthNo As Variant
Dim MonthData As Variant
MonthNo = Month(Worksheets("inputs").Range("B3"))
MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9)
If MonthData = "" Then
MsgBox "Please update losses"
Else
Set pptApp = GetObject(Class:="PowerPoint.Application")
Set pptPrez = pptApp.ActivePresentation
'' JP - use active presentation instead of opening one
''FilePath = "\\Model\"
''Filename = "Template Monthly reports.pptx"
''file = FilePath & Filename
''Set pptPrez = objPPT.Presentations.Open(file)
Set pptPrez = pptApp.ActivePresentation
'Slide 1 title 1
Set pptSlide = pptPrez.Slides(1)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" _
& Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
Set pptShape = pptSlide.Shapes.PasteSpecial(ppPasteDefault)(1)
With pptShape
.Top = 160
.Left = 135
.Height = 80
.Width = 550
End With
End If
End Sub
I have updated the alternative solution which might help others as it does a few things; copies tables to an existing presentation and slides updating old shapes and new shapes, copies pictures to new slides with a pop up box to allow a choice in pasting a table.
I made a function to do this to reduce the main code and make it easier to manage as I had dozens of copies and pastes. I haven't pasted everything but showed some of the different ways to paste:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private pptApp As PowerPoint.Application
Private pptPres As PowerPoint.Presentation
Private pSlide As PowerPoint.Slide
Private TTop, TLeft As Variant
Private TableCount, SlideNo As Integer
Private MyRange As Excel.Range
Private ShapeName As String
Private Function CreateTable()
Dim l As Long
Set pSlide = pptPres.Slides(SlideNo)
MyRange.Copy
pptPres.Windows(1).Activate
pptPres.Windows(1).View.GotoSlide SlideNo
With pptPres.Slides(SlideNo)
If ShapeName = isblank Then
Else
pptPres.Slides(SlideNo).Shapes(ShapeName).Select
End If
For l = 1 To 100
DoEvents
Next l
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
For l = 1 To 500
DoEvents
Next l
pptApp.CommandBars.ReleaseFocus
NoShapes = pSlide.Shapes.Count
If ShapeName = isblank Then
pptPres.Slides(SlideNo).Shapes(NoShapes).Name = "Table" & TableCount
pptPres.Slides(SlideNo).Shapes(ShapeName).Select
With .Shapes("Table" & TableCount)
.LockAspectRatio = msoFalse
If TTop = isblank Then
Else
.Top = TTop
End If
If TLeft = isblank Then
Else
.Left = TLeft
End If
End With
TableCount = TableCount + 1
Else
End If
End With
ShapeName = ""
TLeft = ""
TTop = ""
Application.CutCopyMode = False
End Function
Sub GeneratePresentation()
Dim FilePath, Filename, file As String
Dim MonthNo, MonthData As Variant
Dim x, y As Variant
Dim UpdateRecords As Integer
Dim WB As Excel.Workbook
FilePath = "\\\Model\"
Filename = "Template Weekly Report.pptx"
file = FilePath & Filename
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open(file) ' using a specific presentation or template
Set pptPres = pptApp.ActivePresentation
TableCount = 1
'Slide 1 title 1
SlideNo = 1
Sheets("01").Range("D3") = "= ""Weekly Report """
Sheets("01").Range("D4") = "= ""For Week No. ""&TEXT(WEEKNUM(NOW(),16),""#"")& "" - internal"""
Set MyRange = Sheets("0" & SlideNo).Range("D3:D4")
TTop = 160
TLeft = 135
Call CreateTable
'Slide 1 title 2
Sheets("01").Range("D7").Formula = "=DAY(Entry!B4)&LOOKUP(DAY(Entry!B4),{1,2,3,4,21,22,23,24,31;""st"",""nd"",""rd"",""th"",""st"",""nd"",""rd"",""th"",""st""})&TEXT(Entry!B4,"" mmmm yyy"")"
Set MyRange = Sheets("0" & SlideNo).Range("D7")
TTop = 280
TLeft = 135
Call CreateTable
'slide 2 table 1
SlideNo = 2
Set MyRange = Sheets("0" & SlideNo).Range("B33:T40")
TTop = 380
Call CreateTable
'Slide 2 chart 1
ActiveWorkbook.Sheets("0" & SlideNo).ChartObjects("Chart 1").Copy
Set osh = pSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)(1)
With osh
.Top = 98
.Left = 35
.Width = 430
End With
'Slide 3 table 1
SlideNo = 3
Set pSlide = pptPres.Slides(SlideNo)
UpdateRecords = MsgBox("Update Records", vbYesNo, "Update Records?")
If UpdateRecord = yes Then
Set MyRange = Sheets("0" & SlideNo).Range("E17:I20")
TTop = 330
Call CreateTable
Else
End If
pptPres.Windows(1).Activate
pptPres.Windows(1).View.GotoSlide 1
End Sub
I hope this is helpful.
If you have any recommendation let me know.
Jon
I am pasting ranges from Excel to Powerpoint as Tables.
The problem is that when I paste the first table, positioning works fine (.Top and .Left) but the tables I paste after the first one get positioned relative to the first table.
The .Top becomes the distance between the upper left corner of the table and the upper side of the first table's position (not to the upper side of the slide, as it should be!) and the same thing happens to .Left (it represents the distance between the upper left corner of the table and the left side of the first table).
The code is the following:
Sub ExportaraPowerPoint()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim excelTable As Excel.Range
Dim SlideTitle As String
Dim SlideText As String
Dim SlideObject As Object
Dim pptTextbox As PowerPoint.Shape
Dim SlideNumber As String
Dim xlTable As PowerPoint.Shape
'Check is PPT is open and create if not
On Error Resume Next
Set pptApp = GetObject("", "PowerPoint.Application")
Err.Clear
If pptApp Is Nothing Then Set pptApp = CreateObject(class:="PowerPoint.Application")
pptApp.Visible = True
pptApp.Activate
'Add presentation
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = ppSlideSizeOnScreen
pptPres.ApplyTemplate "c:\Program Files\Microsoft Office\Templates\1033\Blank.potx"
'Assing Tables
Set excelTable1 = Worksheets("TDSACI").Range("N246:U259")
Set excelTable2 = Worksheets("TDCSD").Range("N215:U223")
'Slide 1:
Set pptSlide = pptPres.Slides.Add(1, ppLayoutTitleOnly)
excelTable1.Copy
pptSlide.Shapes.PasteSpecial (ppPasteDefault)
pptSlide.Shapes(2).Width = 670.4
pptSlide.Shapes(2).Height = 292
pptSlide.Shapes(2).Left = 24.4
pptSlide.Shapes(2).Top = 90.4
'Slide 2:
Set pptSlide = pptPres.Slides.Add(2, ppLayoutTitleOnly)
excelTable2.Copy
pptSlide.Shapes.PasteSpecial (ppPasteDefault)
pptSlide.Shapes(2).Width = 670.4
pptSlide.Shapes(2).Height = 292
pptSlide.Shapes(2).Left = 24.4
pptSlide.Shapes(2).Top = 90.4
I know that the table is always the Shape Index number 2, so that is not a problem.
According to numbers, the position of both tables should be the same.
Curious. If you comment out the On Error Resume Next, make sure the VBE is set to Break on All Errors in Options, put a break at the first Slide 2 line, you'll see that the code quits after the .PasteSpecial line but without generating an error. I think this is because PowerPoint is complaining that slide 2 is not in view so the paste method is getting messed up, even if the object appears to be pasted on the slide! I fixed it on my demo deck (PowerPoint 2016) by adding the GotoSlide method:
'Slide 2:
Set pptSlide = pptPres.Slides.Add(2, ppLayoutTitleOnly)
excelTable2.Copy
pptApp.ActiveWindow.View.GotoSlide 2
pptSlide.Shapes.PasteSpecial (ppPasteDefault)
pptSlide.Shapes(2).Width = 670.4
pptSlide.Shapes(2).Height = 292
pptSlide.Shapes(2).Left = 24.4
pptSlide.Shapes(2).Top = 90.4
Manipulating the PowerPoint View isn't necessary to paste objects to slides if the code is running in the PowerPoint VBE so I'm not sure what's going wrong in this case.
The following code to replace the section from 'Assing tables down might be better (and more scalable) if you're looking to deal with more than 2 ranges..
'Assing Tables
Dim excelTables(1) As Range
Set excelTables(0) = Worksheets("TDSACI").Range("N246:U259")
Set excelTables(1) = Worksheets("TDCSD").Range("N215:U223")
For Each myTable In excelTables
myTable.Copy
With pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutTitleOnly)
.Select
With .Shapes.PasteSpecial(ppPasteDefault)
.Width = 670.4
.Height = 292
.Left = 24.4
.Top = 90.4
End With
End With
Next
Ok, here is what I am looking for (Im new, so be gentle):
Copy and paste (default format) from excel to powerpoint (from just the one sheet)
I can only fit so many rows in ppt - so after a slide fills, I want ppt to create a new slide
Same title for each slide is fine!
I only need columns B:K copied over
That's it, however I am stuck :( I know the below code is NOT the best way to write this and it contains errors in which I am sure will be easy to spot. I cannot find how to do this anywhere on the net.
This is what I have so far:
Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim i As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
For i = 1 To 6
'need to set focus to slde 1
PowerPointApp.ActiveWindow.View.GotoSlide (1)
'Deletes Title
'mySlide.Shapes.Title.Delete
'builds new title
mySlide.Shapes.AddShape Type:=msoShapeRectangle, left:=9, Top:=6, Width:=702, Height:=30
mySlide.Shapes(mySlide.Shapes.Count).Line.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Size = 20
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Text = "Current Full Initiative Details – Branded Book as of " & Date
mySlide.Shapes(mySlide.Shapes.Count).Name = "I am TITLE"
mySlide.Shapes(mySlide.Shapes.Count).Line.ForeColor.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).Line.Weight = 1
mySlide.Shapes(mySlide.Shapes.Count).Fill.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).Fill.ForeColor.RGB = RGB(255, 255, 255)
'Copy Range from Excel
Set rng = ActiveWorkbook.Worksheets("RAW").Range("B1:K23")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PowerPointApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShapeRange.left = 10
myShapeRange.Top = 42
myShapeRange.Height = 492
myShapeRange.Width = 702
ActiveWorkbook.Sheets("RAW").Rows("2:23").Delete
Call myPresentation.Slides.Add(1, PpSlideLayout.ppLayoutTitleOnly)
'Clear The Clipboard
Application.CutCopyMode = False
Next i
End Sub
As requested in comments, here is the code I use to copy a slide from a master PPT template to the report PPT.
There is some extraneous code in there to provide status updates on the form we use to drive the process, as well as a debugging flag that I can toggle on/off at run time - these can both be removed.
This will serve as a starting point to finding the proper solution for your situation, and is not a complete answer to the question as asked.
'I've chosen to declare these globally, though it's probably not the best way:
Dim PPTObj As PowerPoint.Application
Dim PPTMaster As PowerPoint.Presentation
Dim PPTClinic As PowerPoint.Presentation
Private Sub InsertPPT(ByVal SlideName As String, ByVal StatusText As String)
Dim Shp As PowerPoint.Shape
Dim Top As Single
Dim Left As Single
Dim Height As Single
Dim width As Single
PPTMaster.Slides(SlideName).Copy
PPTClinic.Slides.Paste
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT"
With PPTClinic.Slides(PPTClinic.Slides.count)
If Debugging Then
.Select
End If
.Design = PPTMaster.Slides(SlideName).Design 'this ensures we get all the right formatting - only seems to be necessary 1 time, but we'll just do it on all
.ColorScheme = PPTMaster.Slides(SlideName).ColorScheme
.FollowMasterBackground = PPTMaster.Slides(SlideName).FollowMasterBackground
For Each Shp In .Shapes 'loop through all the shapes on the slide
If Debugging Then
' .Select
Shp.Select
End If
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT-" & Shp.Name
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
ReLinkShape Shp, TempVars!NewXLName
'need to store off top, left, width, height
Top = Shp.Top
Left = Shp.Left
Height = Shp.Height
width = Shp.width
Shp.LinkFormat.Update 'and force the link to refresh
MySleep 2, "S" 'hopefully, the 2 second pause will allow everything to update properly before moving on.
'then reset them here - they seem to change shape when I update them
Shp.LockAspectRatio = msoFalse
Shp.Top = Top
Shp.Left = Left
Shp.width = width
Shp.Height = Height
ElseIf Shp.Name = "SlideName" And Not Debugging Then 'if it's the "SlideName" tag
Shp.Delete 'delete it (unless we're debugging)
End If
Next
End With
Form_Master.ProcessStatus.Value = StatusText
End Sub
Private Sub ReLinkShape(ByRef Shp As PowerPoint.Shape, ByVal NewDestination As String)
Dim Link() As String
Dim link2() As String
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
Link = Split(Shp.LinkFormat.SourceFullName, "!") 'update the link to point to the new clinic spreadsheet instead of the master
If InStr(1, Link(2), "]") > 0 Then
link2 = Split(Link(2), "]")
Link(2) = "[" & TempVars!ClinicName & ".xlsx]" & link2(1)
End If
Shp.LinkFormat.SourceFullName = NewDestination & "!" & Link(1) & "!" & Link(2)
End If
End Sub
Public Sub MySleep(ByRef Unit As Double, ByRef UOM As String)
Dim Pause As Date
Pause = DateAdd(UOM, Unit, Now())
While Now < Pause
DoEvents
Wend
End Sub
I have the following VBA code which let me paste an excel file into a powerpoint. I works, but after a paste it I would also like to size it (make it a little smaller) and move it to the right upper corner.
Any suggestions on how I should change code below to accomplish this?
Dear regards,
Marc
Sub OpenPPT()
Dim pptapp As PowerPoint.Application
Dim ppt As PowerPoint.Presentation
Dim slide As PowerPoint.slide
Dim shape As PowerPoint.shape
var2 = "C:\Documents and Settings\aa471714\Desktop\Presentation1.ppt"
Set pptapp = CreateObject("Powerpoint.Application")
Set ppt = pptapp.Presentations.Open(var2)
Set slide = ppt.Slides(1)
Set shape = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
pptapp.Visible = True
With slide
.Shapes.Paste
End With
End Sub
Instead of this bit:
With slide
.Shapes.Paste
End With
Substitute this:
Set shape = slide.shapes.paste(1)
With shape
.Left = 100 ' or whatever
.Width = 500 ' or whatever
End With