I am building a macro that takes excel data and puts in PowerPoint presentation, however the presentation that is created from scratch by my macro contains default Office SlideMaster in opposition to a new presentation created by opening PowerPoint manually which contains SlideMaster loaded from
C:\Users\xxxx\AppData\Roaming\Microsoft\Windows\Templates\blank.potx which is a company slidemaster. I want the macro to create a presentation with company slidemaster, the problem is that the macro will be ran on different computers therefore I can not use the path to blank.potx (username changes).
Is it possible to make it work that way?
Here is the beggining of my code:
Sub mainsub()
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim mySlide2 As Object
Dim myShape As Object
Dim myShape1 As Object
Dim myShape2 As Object
Dim ws As Worksheet
Set formularz = ThisWorkbook.Sheets("formularz")
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
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, 12)
With myPresentation.PageSetup
.SlideWidth = 800
.SlideHeight = 450
End With
ThisWorkbook.Sheets("formularz").Activate
PowerPointApp.Visible = True
PowerPointApp.Activate
PowerPointApp.WindowState = 2
mySlide.Select
Set myShape1 = mySlide.Shapes.addTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
text1 = formularz.Range("B2").text
myShape1.TextFrame.TextRange.text = text1
myShape1.top = 0
myShape1.TextFrame.TextRange.Font.Name = "Helvetica 75"
myShape1.TextFrame.TextRange.Font.Color.RGB = RGB(255, 102, 0)
myShape1.TextFrame.WordWrap = 0
myShape1.left = 400 - myShape1.width / 2
PowerPointApp.ActiveWindow.Selection.Unselect
.
.
.
and so on, mainly creating great number of another slides and shapes.
Probably the answer to my question is (to be put) somewhere in above code.
Thanks for any piece of advice
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
my program :
produce a picture that is extracting data from excel .
Paste it in word and make the page setting as Landscape .
However ,the picture generated is small and the setting of page become custom.
the photo is so wide .I don't want to enlarge by myself everytimes.
How can I add this setting in vba ?Make it as large and wide as it can .
Secondly , it is pleasure that the data extracted can be pasted as table format.
my codes :
Private Sub CommandButton1_Click()
Dim tbl0 As Excel.RANGE
Dim Tbl As Excel.RANGE
Dim tbl2 As Excel.RANGE
Dim wordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("17-18") ' Change e.g. sheet9.Name
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Value1 = Me.TextBox1.Value
Value2 = Me.TextBox2.Value
ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE
'Copy Range from Excel
'Set tbl0 = ws.RANGE("A78:I83")
Set Tbl = ws.RANGE("A78:I92")
' Set tbl2 = ws.Range("A90:I92")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set wordApp = GetObject(Class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If wordApp Is Nothing Then Set wordApp = CreateObject(Class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
wordApp.Visible = True
wordApp.Activate
'Create a New Document
Set myDoc = wordApp.Documents.Add
'Trigger copy separately for each table + paste for each table
Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wordApp.Selection.Paste
wordApp.Selection.TypeParagraph
wordApp.Selection.PageSetup.Orientation = wdOrientLandscape
resize_all_images_to_page_width myDoc
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Although I don't fiddle with Word but Excel only it might give you an idea...
The code of my XmasPrep excel sucks in a bunch of pictures in order to produce a catalog, listing the pictures to select from.
For each line, i.e. each picture, the code
assigns an Excel cell range and then resizes the range ROW height and width
as well as the range height itself
assigns the picture object thisPic = .Parent.Pictures.Insert(picFileName) and then resizes that according to the cell range's coordinates and size:
thisPic.Top = .Top + 1
thisPic.Left = .Left + 1
thisPic.Width = .Width - 2
thisPic.Height = .Height - 2
So, if you're able to grab the picture object (thisPic) in Word you might be able to resize it to your needs as well. Hope it helps.
:
Const MaxHeight = 50
Const MaxWidth = 14
Dim picFileName As String
Dim i, j, k As Long
Dim col_Filenames As Long
Dim col_Pictures As Long
Dim range_PicCell As Range
Dim thisPic As Picture
:
picFileName = filesPath & select2order.Cells(i, col_Filenames).Value
Set range_PicCell = select2order.Cells(i, col_Pictures)
range_PicCell.RowHeight = MaxHeight
range_PicCell.ColumnWidth = MaxWidth
With range_PicCell
.Height = MaxHeight
Set thisPic = .Parent.Pictures.Insert(picFileName)
thisPic.Top = .Top + 1
thisPic.Left = .Left + 1
thisPic.Width = .Width - 2
thisPic.Height = .Height - 2
End With
:
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 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")
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