This is the code I wrote to copy over a picture from Excel to PowerPoint. I have other code that preps the PowerPoint slide, which should have no factor on this. For some reason this code is not working. It is giving me the error that no slide is currently in view. Thanks in advance for the help.
Sub CopyPicToPPt()
Dim pptApp As PowerPoint.Application
Dim pptPresent As Presentation
Dim sldPPT As Slide
Dim shpPic As Shape
Dim oLayout As CustomLayout
Dim x As PowerPoint.Shape
ActiveWorkbook.Sheets("Sheet1").Select
Set shpPic = Sheet4.Shapes("Picture 3") '<< --- Pic Name
shpPic.CopyPicture
Set pptApp = GetObject(class:="PowerPoint.Application")
pptApp.Visible = True
pptApp.Activate
Set pptPresent = pptApp.ActivePresentation
Set sldPPT = pptApp.ActiveWindow.View.Slide
sldPPT.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
pptApp.ActiveWindow.Selection.ShapeRange.Left = 24
pptApp.ActiveWindow.Selection.ShapeRange.Top = 6
pptApp.ActiveWindow.Selection.ShapeRange.Height = 55
pptApp.ActiveWindow.Selection.ShapeRange.width = 672
End Sub
After a little fiddling and some help from a friend I think I have it! - Cheers
Sub CopyPicToPPt()
Dim pptApp As PowerPoint.Application
Dim pptPresent As Presentation
Dim sldPPT As Slide
Dim shpPic As Shape
Dim oLayout As CustomLayout
Dim x As PowerPoint.Shape
ActiveWorkbook.Sheets("Sheet1").Visible = True
ActiveWorkbook.Sheets("Sheet1").Select
Set shpPic = Sheet4.Shapes("Picture 3") '<< --- Pic Name
shpPic.CopyPicture
Set pptApp = GetObject(class:="PowerPoint.Application")
pptApp.Visible = True
pptApp.Activate
pptApp.ActivePresentation.Slides(1).Select
Set pptPresent = pptApp.ActivePresentation
Set sldPPT = pptApp.ActivePresentation.Slides(1)
sldPPT.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
pptApp.ActiveWindow.Selection.ShapeRange.Left = 24
pptApp.ActiveWindow.Selection.ShapeRange.Top = 6
pptApp.ActiveWindow.Selection.ShapeRange.Height = 55
pptApp.ActiveWindow.Selection.ShapeRange.width = 672
ActiveWorkbook.Sheets("Sheet1").Visible = False
End Sub
Related
I am trying to make the exported charts larger on the powerpoint slide, but keep running into issues with the loop. Any ideas?
Sub Export_Worksheet()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim SldIndex As Integer
Dim Chrt As ChartObject
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
SldIndex = 1
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Copy
Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
PPTSlide.Shapes.Paste
SldIndex = SldIndex + 1
Next Chrt
End Sub
Check this code. It's works, if you need copy one chart on one slide, change size and position of chart and then repeat action for next slides
Sub Export_Worksheet()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim SldIndex As Integer
Dim Chrt As ChartObject
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
SldIndex = 1
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Copy
Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
PPTSlide.Shapes.Paste
With PPTPres.Slides(SldIndex).Shapes("Chart 1")
.Top = 170
.Left = 530
.Height = 250
.Width = 400
End With
SldIndex = SldIndex + 1
Next Chrt
End Sub
Sub Export_Allcahrts_ppt()
Dim mypowerpoint As PowerPoint.Application
Set mypowerpoint = New PowerPoint.Application
mypowerpoint.Visible = msoTrue
Dim mypowerpoint_pres As PowerPoint.Presentation
Set mypowerpoint_pres = mypowerpoint.Presentations.Add
Dim myslide As PowerPoint.Slide
Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank)
Dim mychart As ChartObject
Dim j As Long
j = 0
For Each mychart In Sheet1.ChartObjects
j = j + 1
Next
For Each mychart In Sheet1.ChartObjects
mychart.Copy
myslide.Shapes.PasteSpecial ppPasteBitmap
myslide.Shapes(1).Top = 100
myslide.Shapes(1).Height = 200
myslide.Shapes(1).Left = 30
If mypowerpoint_pres.Slides.Count < j Then
Set myslide = mypowerpoint_pres.Slides.Add(mypowerpoint_pres.Slides.Count + 1, ppLayoutBlank)
Else
Exit Sub
End If
Next
End Sub
First, you don't need to loop to get j; just use
j = Sheet1.ChartObjects.Count
But you also don't need j at all. What your code does is insert a new slide for each new chart if the number of slides does not yet equal the number of charts copied so far.
So try this slightly rearranged and streamlined code. I haven't tested it, but I don't think I've changed the syntax.
Sub Export_Allcahrts_ppt()
Dim mypowerpoint As PowerPoint.Application
Dim mypowerpoint_pres As PowerPoint.Presentation
Dim myslide As PowerPoint.Slide
Dim mychart As ChartObject
Dim j As Long
Set mypowerpoint = New PowerPoint.Application
mypowerpoint.Visible = msoTrue
Set mypowerpoint_pres = mypowerpoint.Presentations.Add
Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank)
j = Sheet1.ChartObjects.Count
For Each mychart In Sheet1.ChartObjects
mychart.Copy
myslide.Shapes.PasteSpecial ppPasteBitmap
With myslide.Shapes(myslide.Shapes.Count)
.Top = 100
.Height = 200
.Left = 30
End With
Next
End Sub
I have following code -
Option Explicit
Sub main()
Dim oPPTApp As PowerPoint.Application
Dim oPPTObj As Object
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Dim oGraph As Graph.Chart
Dim oAxis As Graph.Axis
Dim SlideNum As Integer
Dim strPresPath As String, strNewPresPath As String
strPresPath = "Location.ppt"
strNewPresPath = "Destination.ppt"
'instantiate the powerpoint application and make it visible
Set oPPTObj = CreateObject("PowerPoint.Application")
oPPTObj.Visible = msoCTrue
Set oPPTFile = oPPTObj.Presentations.Open(strPresPath)
SlideNum = 1
Set oPPTSlide = oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTSlide.Add(1, ppLayoutBlank)
oPPTSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 10, 20, 300, 5
With oPPTSlide.Shapes(1).TextFrame.TextRange
.text = "ALL BSE"
.Font.Color = vbWhite
.Font.Underline = msoFalse
End With
End Sub
I get an error
Expected Function or Variable
at the following line:
Set oPPTSlide = oPPTFile.Slides(SlideNum).Select
Any help would be appreciated.
Following my comment above, you can't Set and Select at the same line (also, there's almost never any reason to use Select). Try Set oPPTSlide = oPPTFile.Slides(SlideNum)
However, a few "upgrades" to your code:
Directly set the oPPTShape with the new created Shapes with :
Set oPPTShape = oPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 20, 300, 5)
and afterwards, easily modify the oPPTShape properties, using the With statement below:
With oPPTShape.TextFrame.TextRange
.text = "ALL BSE"
.Font.Color = vbWhite
.Font.Underline = msoFalse
End With
Should be...
Set oPPTSlide = oPPTFile.Slides(SlideNum)
My goal is to creat ppt via VBA. I have already the template in my desktop that i need to use. This part of the code is ok.
However I did not find how to select slides in the ppt. I try many ways and i get all the times error.
If someone could help me.
Option Explicit
Sub CreatePowerPoint()
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.SlideRange
Dim strTemplate As String
Dim rng As Range
strTemplate = "C:\Users\290866\Desktop\vba\PPT\Template.potx"
Set oPA = New PowerPoint.Application
oPA.Visible = msoTrue
oPA.Presentations.Open strTemplate, untitled:=msoTrue
If Not oPS Is Nothing Then Set oPS = Nothing
If Not oPP Is Nothing Then Set oPP = Nothing
If Not oPA Is Nothing Then Set oPA = Nothing
Err_PPT:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If
Set rng = ThisWorkbook.Sheets("Credit Recommendation").Range("B2:N59")
ActivePresentation.Slides (1)
rng.Copy
mySlide.Shapes.PasteSpecial (ppPasteBitmap)
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
myShapeRange.LockAspectRatio = msoFalse
myShapeRange.Left = 20
myShapeRange.Top = 80
myShapeRange.Height = 400
myShapeRange.Width = 680
Application.CutCopyMode = False
End Sub
Thank you!!!
Here is your code modified to work. I explain the modifications below
Option Explicit
Sub CreatePowerPoint()
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.SlideRange
Dim strTemplate As String
Dim rng As Range
strTemplate = "C:\Users\290866\Desktop\vba\PPT\Template.potx"
Set oPA = New PowerPoint.Application
oPA.Visible = msoTrue
'changed this line to assign the new presentation to your variable
Set oPP = oPA.Presentations.Open(strTemplate, untitled:=msoTrue)
'If Not oPS Is Nothing Then Set oPS = Nothing
'If Not oPP Is Nothing Then Set oPP = Nothing
'If Not oPA Is Nothing Then Set oPA = Nothing
Err_PPT:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If
Set rng = ThisWorkbook.Sheets("sheet1").Range("B2:N59")
Set mySlide = oPP.Slides(1)
rng.Copy
mySlide.Shapes.PasteSpecial (ppPasteBitmap)
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
myShapeRange.LockAspectRatio = msoFalse
myShapeRange.Left = 20
myShapeRange.Top = 80
myShapeRange.Height = 400
myShapeRange.Width = 680
Application.CutCopyMode = False
End Sub
You were declaring variables and never setting them equal to anything. I still did not see where oPS was ever used.
You received the ActiveX error because PowerPoint did not have an active presentation. It is always safer to work with your own objects rather than ActiveAnything within Office. So I set oPP equal to your new presentation and then used oPP rather than ActivePresentation
Also you never need to set things equal to nothing unless you're being picky about the order it happens. Everything declared in the Sub is set to nothing at the end of the sub.
Hope this helps!
Edit: Search and Replace
This is where I got the code, but I modified it to work as a callable Sub because I was calling it from different places many times:
'Find and Replace function
Sub FindAndReplace(sFind As String, sReplace As String, ByRef ppPres As PowerPoint.Presentation)
Dim osld As PowerPoint.Slide
Dim oshp As PowerPoint.Shape
Dim otemp As PowerPoint.TextRange
Dim otext As PowerPoint.TextRange
Dim Inewstart As Integer
For Each osld In ppPres.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set otext = oshp.TextFrame.TextRange
Set otemp = otext.Replace(sFind, sReplace, , msoFalse, msoFalse)
Do While Not otemp Is Nothing
Inewstart = otemp.Start + otemp.Length
Set otemp = otext.Replace(sFind, sReplace, Inewstart, msoFalse, msoFalse)
Loop
End If
End If
Next oshp
Next osld
End Sub
You'll have to pass it the 2 strings and the Presentation object. It'll look like this in your Sub
FindAndReplace("FindMe","ReplaceWithThis", oPP)
i am trying to populate some text fields in a powerpoint file using the below code:
Private Sub OpenPPT_Click()
Dim pptPres As PowerPoint.Presentation
Dim pptApp As PowerPoint.Application
Dim currentSlide As Slide
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Open("C:\Users\Magda\Desktop\TestReport.pptx")
Set currentSlide = pptPres.Slides(pptPres.Slides.Count)
'Slide 1
currentSlide.Shapes("HomeTitle1").TextFrame.TextRange.Text = "This is the title"
currentSlide.Shapes("HomeTitle2").TextFrame.TextRange.Text = "This is the subtitle"
'Slide 2
currentSlide.Shapes("MainTitle1").TextFrame.TextRange.Text = "This is the title"
currentSlide.Shapes("Contents1").TextFrame.TextRange.Text = "Section1"
currentSlide.Shapes("Contents2").TextFrame.TextRange.Text = "Section2"
currentSlide.Shapes("Contents3").TextFrame.TextRange.Text = "Section3"
currentSlide.Shapes("Contents4").TextFrame.TextRange.Text = "Section4"
'Slide 3
currentSlide.Shapes("MainTitle2").TextFrame.TextRange.Text = "Section1"
End Sub
My issue is that this code only seems to set text in slide 3 (final slide in PPT). How do i loop through the slides so that each gets populated?
The following code works for me, looping through each slide (Access 2010 manipulating PowerPoint 2010):
Option Compare Database
Option Explicit
Sub pptTest()
Dim pptApp As New PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim currentSlide As Slide
Dim i As Long
Set pptPres = pptApp.Presentations.Open("C:\Users\Gord\Desktop\TestReport.pptx")
For i = 1 To pptPres.Slides.Count
Set currentSlide = pptPres.Slides(i)
Debug.Print currentSlide.Name
Next
Set currentSlide = Nothing
pptPres.Close
Set pptPres = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub
Of course, if you need to do slightly different things to each slide you could just do
Set currentSlide = pptPres.Slides(1)
' do stuff for Slide 1
Set currentSlide = pptPres.Slides(2)
' do stuff for Slide 2
' and so on