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
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
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
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
I have an Excel Picture as Shape and i want to paste it to mny PowerPoint app which has a Special layout which i have already specified.
Sub ExcelShapePowerpoint()
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim pastedPic1 As Shape
Set DestinationSheet1 = Workbooks("myExcelFile.xlsm").Sheets("myExcelSheet")
Set pastedPic1 = DestinationSheet1.Shapes(10)
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Application.ScreenUpdating = False
Set myPresentation = PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
With myPresentation.PageSetup
.SlideWidth = 961
.SlideHeight = 540
End With
pastedPic1.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = -15
myShape.Top = 11
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
End Sub
As its obvious from the code the layout is already set. Now i want the pastedpic1 to fit completely to the layout of the PowerPoint.
What should i do ?
To scale the shape myShape to the size of the slide, use this:
With myShape
.Top = 0
.Left = 0
.Width = ActivePresentation.PageSetup.SlideWidth
.Height = ActivePresentation.PageSetup.SlideHeight
End With
Note that depending on the aspect ratio of your shape and slide, stretching may occur. This can be dealt with using the cropping methods.
I had a similar problem but took another approach:
I created a PowerPoint template where I added Picture placeholders to the destinations where the pictures have to be inserted. This approach has the advantage, that you can edit the layout in PowerPoint and do not have to fiddle with pixel sizes in the basic code.
The following example is in VBScript but can be transfered to VBA easily:
Open the PowerPoint template:
Dim powerPoint, presentation
Set powerPoint = CreateObject("PowerPoint.Application")
Set presentation = powerPoint.Presentations.open("C:\template.pptx")
Select the Placeholder, and paste the picture:
Dim slide, view, image, placeholder
Set view = m_presentation.Windows(1).View
Set slide = m_presentation.Slides(slideId)
view.GotoSlide(slide.SlideIndex)
Set placeholder = slide.Shapes(shapeName)
placeholder.Select()
view.Paste()
slide.Application.CommandBars.ExecuteMso("PictureFitCrop")
Scale the picture to fit the size of the placeholder:
slide.Application.CommandBars.ExecuteMso("PictureFitCrop")
I'm trying to create a command to automatically export a PDF in PowerPoint.
I have a command to paste a photo that is working. However, it just pastes to the top left of the screen.
I have been looking on the web for a script to align to the center of the slide and stretch to fit the slideshow page. I tried to record it but it seems as if PowerPoint does not have a record function.
Here is my Copy + Paste script that works below.
Sub PastePhoto()
Dim Sld As Slide
'Ensure focus is on slide
Application.ActiveWindow.Panes(2).Activate
Set Sld = Application.ActiveWindow.View.Slide
On Error GoTo NoCopy
Sld.Shapes.PasteSpecial (ppPasteEnhancedMetafile)
On Error GoTo 0
Exit Sub
NoCopy:
MsgBox "There was nothing copied to paste!"
This should be all that's needed to insert a picture into your slide and stretch it to fit the slide's width:
' Get the first slide...
Dim sl As Slide
Set sl = ActivePresentation.Slides(1)
' Insert a picture at (0, 0)...
Dim sh As Shape
Set sh = sl.Shapes.AddPicture("c:\path\to\my.jpg", msoFalse, msoTrue, 0, 0)
' Set the picture's width to that of a slide...
sh.Width = ActivePresentation.PageSetup.SlideWidth
And if you want to center it vertically:
sh.Top = (ActivePresentation.PageSetup.SlideHeight - sh.Height) / 2
After some tweaking I've figured it out :)
Sub PastePhoto()
Const ppLayoutBlank = 12
Dim objWorkSheet As Worksheet
Dim objRange As Range
Set objWorkSheet = ThisWorkbook.ActiveSheet
Range("A1:H18").Select
Range("H18").Activate
Selection.Copy
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set objPresentation = objPPT.Presentations.Add
Set objSlide = objPresentation.Slides.Add(1, 1)
objPresentation.Slides(1).Layout = ppLayoutBlank
' paste as the meta file
objPPT.Windows(1).View.PasteSpecial ppPasteMetafilePicture, msoTrue, , , "testlabel"
End Sub