How do I copy and paste a powerpoint slide from excel using vba code

Are you automating PowerPoint or Excel?

Either way, you'll probably need to know some PowerPoint VBA.

HTH,
JP

"LilacSpokane" <(E-Mail Removed)> wrote in message
news:B46CD1B1-9260-4F41-9C98-(E-Mail Removed)...
> How do I copy and paste a powerpoint slide from excel using vba code

' I'm assuming you want to transfer with VBA Excel stuff into PP
slides. For that
' Copy and paste the below code into a new VBA code module.
' After you have selected in Excel one or multiple charts or one or
multiple areas start the macro
' "CreateSlidesFromSelection" . Then the macro will paste these
selections as pictures
' in new or existing PP slides. By default new PP sildes will be
created, by
' pressing the shift key you can make it paste to the ccurrently
active slide, unless there is active slide. I'm
' starting this macro with a custom button on my custom toolbar.
' Works like a charm and is a great time saver if you have to create
PP slides with Excel content frequently.

'--------------------------------------------------------------------------------------------------------------------------------------
Option Explicit

Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey
As Long) As Integer

Function Key_pressed(key_to_check As Long) As Boolean
If GetAsyncKeyState(key_to_check) And &H8000 Then
Key_pressed = True
Else
Key_pressed = False
End If
End Function

Sub CreateSlidesFromSelection()
''' COPY ONE OR MULTIPLE SELECTED EXCEL CHARTS OR SELECTED AREAS
INTO POWERPOINT
' In the "tools" menu of the Visual Basic Editor set a reference to
' Microsoft PowerPoint Object Library
Dim Sh As Shape
Dim i As Integer
Dim titel As String
Dim new_slide As Boolean
Dim half_size As Boolean
Dim PasteSuccess As Boolean


' In case the shift key is pressed down while starting the macro
' the selection will be posted into an existing slide if available.
' if no slide or no presentation is open it will be created.
new_slide = Not Key_pressed(vbKeyShift)

' In case the Control key is pressed down while starting the macro
' the selection will be posted on the right side of the slide with
' a smaller scaling to allow for text on the left side of the slide
half_size = Key_pressed(vbKeyControl)

On Error GoTo exitsub
If Not ActiveChart Is Nothing Then ' one chart is selected
On Error Resume Next
titel = ActiveChart.ChartTitle.Characters.Text & " "
titel = titel &
ActiveChart.Axes(xlValue).AxisTitle.Characters.Text
On Error GoTo 0
' Copy chart as a picture
Application.ActiveChart.CopyPicture Appearance:=xlScreen,
Size:=xlScreen, Format:=xlPicture
Call PasteChart(new_slide, half_size, titel)
PasteSuccess = True
Else
On Error Resume Next
i = Selection.ShapeRange.Count 'if there is no error multiple
charts are selected
If err.Number = 0 Then ' err.number is zero because we have a
multiple selection
' err.Clear
On Error GoTo 0
For Each Sh In Selection.ShapeRange
If Sh.Type = msoChart Then ' IS SHAPE A CHART?
Sh.Select
Application.ActiveChart.CopyPicture
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
titel = ""
On Error Resume Next
titel = ActiveChart.ChartTitle.Characters.Text & " "
titel = titel &
ActiveChart.Axes(xlValue).AxisTitle.Characters.Text
On Error GoTo 0
Call PasteChart(new_slide, half_size, titel)
PasteSuccess = True
End If
Next
Else ' in case no charts we might have one or more cell
selections
For i = 1 To Selection.Areas.Count
If Selection.Areas(i).Cells.Count < 2 Then
If MsgBox("You have selected a single cell." & Chr(10)
& _
"Should this single cell be copied to
PowerPoint?", vbYesNo) = vbNo Then
GoTo nextone
End If
End If
Selection.Areas(i).Copy
Call PasteChart(new_slide, half_size, titel)
PasteSuccess = True
Application.CutCopyMode = False
nextone:
Next i
End If
End If
If PasteSuccess Then getPP.Activate
' Application.WindowState = xlMinimized
exitsub:
End Sub
Private Sub PasteChart(newSlide As Boolean, toTheRight As Boolean,
slideTitle As String)
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim sID As Integer ' as slideindex
Dim cScale As Single
Dim ChartHeight As Integer
Dim ChartWidth As Integer

Set PPApp = getPP()
Set PPPres = getPresentation(PPApp)
On Error Resume Next
If newSlide Then
sID = 1
sID = sID + PPApp.ActiveWindow.Selection.SlideRange.SlideIndex
'lets add below the actual one
PPPres.Slides.Add sID, ppLayoutTitleOnly ' add a slide as #1
or below the actual one
Else
sID = PPApp.ActiveWindow.Selection.SlideRange.SlideIndex 'is
there a slide existing?
If sID = 0 Then 'in case there is no slide
sID = 1
PPPres.Slides.Add sID, ppLayoutTitleOnly ' add a slide to
the empty presentation
End If
End If
On Error GoTo 0
PPPres.Slides(sID).Select
PPApp.ActiveWindow.ViewType = ppViewSlide
Set PPSlide =
PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
ChartHeight = PPApp.ActiveWindow.Selection.ShapeRange.Height
ChartWidth = PPApp.ActiveWindow.Selection.ShapeRange.Width
If ChartWidth / ChartHeight > 1.75 Then
cScale = 700 / ChartWidth
Else
cScale = 400 / ChartHeight
End If
If toTheRight Then ' Scale and Align pasted chart
cScale = cScale / 1.5
With PPApp.ActiveWindow.Selection.ShapeRange
.ScaleWidth cScale, msoFalse, msoScaleFromTopLeft
.ScaleHeight cScale, msoFalse, msoScaleFromBottomRight
.Align msoAlignRights, True
.Align msoAlignMiddles, True
.IncrementLeft -25#
End With
Else
With PPApp.ActiveWindow.Selection.ShapeRange
.ScaleWidth cScale, msoFalse, msoScaleFromTopLeft
.ScaleHeight cScale, msoFalse, msoScaleFromBottomRight
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.IncrementTop 12#
End With
End If

PPApp.ActiveWindow.ViewType = ppViewNormal
If PPSlide.Shapes.title.TextFrame.TextRange.Text = "" Then 'set
title in case there is none already
PPSlide.Shapes.title.TextFrame.TextRange.Text = slideTitle
End If

Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
Private Function getPP() As PowerPoint.Application
On Error Resume Next
Set getPP = GetObject("Powerpoint.Application")
If err.Number <> 0 Then ' iff PP isn't there lets start it
Set getPP = CreateObject("Powerpoint.Application")
err.Clear
End If
getPP.Visible = msoCTrue
End Function
Private Function getPresentation(PPApp As PowerPoint.Application) As
PowerPoint.Presentation
' Reference active presentation
On Error Resume Next
Set getPresentation = PPApp.ActivePresentation
If err.Number <> 0 Then 'if no presentation lets create one
Set getPresentation = PPApp.Presentations.Add(True)
err.Clear
End If
End Function

If you want to use a macro, look here:
http://peltiertech.com/Excel/XL_PPT.html

Personally, I would just embed a link to the .ppt slide that you are working
with:
http://presentationsoft.about.com/od...xcelchrt_3.htm
I've used this technique with great success!!

Regards,
Ryan---

--
RyGuy


"minimaster" wrote:

> ' I'm assuming you want to transfer with VBA Excel stuff into PP
> slides. For that
> ' Copy and paste the below code into a new VBA code module.
> ' After you have selected in Excel one or multiple charts or one or
> multiple areas start the macro
> ' "CreateSlidesFromSelection" . Then the macro will paste these
> selections as pictures
> ' in new or existing PP slides. By default new PP sildes will be
> created, by
> ' pressing the shift key you can make it paste to the ccurrently
> active slide, unless there is active slide. I'm
> ' starting this macro with a custom button on my custom toolbar.
> ' Works like a charm and is a great time saver if you have to create
> PP slides with Excel content frequently.
>
> '--------------------------------------------------------------------------------------------------------------------------------------
> Option Explicit
>
> Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey
> As Long) As Integer
>
> Function Key_pressed(key_to_check As Long) As Boolean
> If GetAsyncKeyState(key_to_check) And &H8000 Then
> Key_pressed = True
> Else
> Key_pressed = False
> End If
> End Function
>
> Sub CreateSlidesFromSelection()
> ''' COPY ONE OR MULTIPLE SELECTED EXCEL CHARTS OR SELECTED AREAS
> INTO POWERPOINT
> ' In the "tools" menu of the Visual Basic Editor set a reference to
> ' Microsoft PowerPoint Object Library
> Dim Sh As Shape
> Dim i As Integer
> Dim titel As String
> Dim new_slide As Boolean
> Dim half_size As Boolean
> Dim PasteSuccess As Boolean
>
>
> ' In case the shift key is pressed down while starting the macro
> ' the selection will be posted into an existing slide if available.
> ' if no slide or no presentation is open it will be created.
> new_slide = Not Key_pressed(vbKeyShift)
>
> ' In case the Control key is pressed down while starting the macro
> ' the selection will be posted on the right side of the slide with
> ' a smaller scaling to allow for text on the left side of the slide
> half_size = Key_pressed(vbKeyControl)
>
> On Error GoTo exitsub
> If Not ActiveChart Is Nothing Then ' one chart is selected
> On Error Resume Next
> titel = ActiveChart.ChartTitle.Characters.Text & " "
> titel = titel &
> ActiveChart.Axes(xlValue).AxisTitle.Characters.Text
> On Error GoTo 0
> ' Copy chart as a picture
> Application.ActiveChart.CopyPicture Appearance:=xlScreen,
> Size:=xlScreen, Format:=xlPicture
> Call PasteChart(new_slide, half_size, titel)
> PasteSuccess = True
> Else
> On Error Resume Next
> i = Selection.ShapeRange.Count 'if there is no error multiple
> charts are selected
> If err.Number = 0 Then ' err.number is zero because we have a
> multiple selection
> ' err.Clear
> On Error GoTo 0
> For Each Sh In Selection.ShapeRange
> If Sh.Type = msoChart Then ' IS SHAPE A CHART?
> Sh.Select
> Application.ActiveChart.CopyPicture
> Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
> titel = ""
> On Error Resume Next
> titel = ActiveChart.ChartTitle.Characters.Text & " "
> titel = titel &
> ActiveChart.Axes(xlValue).AxisTitle.Characters.Text
> On Error GoTo 0
> Call PasteChart(new_slide, half_size, titel)
> PasteSuccess = True
> End If
> Next
> Else ' in case no charts we might have one or more cell
> selections
> For i = 1 To Selection.Areas.Count
> If Selection.Areas(i).Cells.Count < 2 Then
> If MsgBox("You have selected a single cell." & Chr(10)
> & _
> "Should this single cell be copied to
> PowerPoint?", vbYesNo) = vbNo Then
> GoTo nextone
> End If
> End If
> Selection.Areas(i).Copy
> Call PasteChart(new_slide, half_size, titel)
> PasteSuccess = True
> Application.CutCopyMode = False
> nextone:
> Next i
> End If
> End If
> If PasteSuccess Then getPP.Activate
> ' Application.WindowState = xlMinimized
> exitsub:
> End Sub
> Private Sub PasteChart(newSlide As Boolean, toTheRight As Boolean,
> slideTitle As String)
> Dim PPApp As PowerPoint.Application
> Dim PPPres As PowerPoint.Presentation
> Dim PPSlide As PowerPoint.Slide
> Dim sID As Integer ' as slideindex
> Dim cScale As Single
> Dim ChartHeight As Integer
> Dim ChartWidth As Integer
>
> Set PPApp = getPP()
> Set PPPres = getPresentation(PPApp)
> On Error Resume Next
> If newSlide Then
> sID = 1
> sID = sID + PPApp.ActiveWindow.Selection.SlideRange.SlideIndex
> 'lets add below the actual one
> PPPres.Slides.Add sID, ppLayoutTitleOnly ' add a slide as #1
> or below the actual one
> Else
> sID = PPApp.ActiveWindow.Selection.SlideRange.SlideIndex 'is
> there a slide existing?
> If sID = 0 Then 'in case there is no slide
> sID = 1
> PPPres.Slides.Add sID, ppLayoutTitleOnly ' add a slide to
> the empty presentation
> End If
> End If
> On Error GoTo 0
> PPPres.Slides(sID).Select
> PPApp.ActiveWindow.ViewType = ppViewSlide
> Set PPSlide =
> PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
> PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
> ChartHeight = PPApp.ActiveWindow.Selection.ShapeRange.Height
> ChartWidth = PPApp.ActiveWindow.Selection.ShapeRange.Width
> If ChartWidth / ChartHeight > 1.75 Then
> cScale = 700 / ChartWidth
> Else
> cScale = 400 / ChartHeight
> End If
> If toTheRight Then ' Scale and Align pasted chart
> cScale = cScale / 1.5
> With PPApp.ActiveWindow.Selection.ShapeRange
> .ScaleWidth cScale, msoFalse, msoScaleFromTopLeft
> .ScaleHeight cScale, msoFalse, msoScaleFromBottomRight
> .Align msoAlignRights, True
> .Align msoAlignMiddles, True
> .IncrementLeft -25#
> End With
> Else
> With PPApp.ActiveWindow.Selection.ShapeRange
> .ScaleWidth cScale, msoFalse, msoScaleFromTopLeft
> .ScaleHeight cScale, msoFalse, msoScaleFromBottomRight
> .Align msoAlignCenters, True
> .Align msoAlignMiddles, True
> .IncrementTop 12#
> End With
> End If
>
> PPApp.ActiveWindow.ViewType = ppViewNormal
> If PPSlide.Shapes.title.TextFrame.TextRange.Text = "" Then 'set
> title in case there is none already
> PPSlide.Shapes.title.TextFrame.TextRange.Text = slideTitle
> End If
>
> Set PPSlide = Nothing
> Set PPPres = Nothing
> Set PPApp = Nothing
> End Sub
> Private Function getPP() As PowerPoint.Application
> On Error Resume Next
> Set getPP = GetObject("Powerpoint.Application")
> If err.Number <> 0 Then ' iff PP isn't there lets start it
> Set getPP = CreateObject("Powerpoint.Application")
> err.Clear
> End If
> getPP.Visible = msoCTrue
> End Function
> Private Function getPresentation(PPApp As PowerPoint.Application) As
> PowerPoint.Presentation
> ' Reference active presentation
> On Error Resume Next
> Set getPresentation = PPApp.ActivePresentation
> If err.Number <> 0 Then 'if no presentation lets create one
> Set getPresentation = PPApp.Presentations.Add(True)
> err.Clear
> End If
> End Function
>

Thank you very much. That had exactly what I needed in it.

"minimaster" wrote:

> ' I'm assuming you want to transfer with VBA Excel stuff into PP
> slides. For that
> ' Copy and paste the below code into a new VBA code module.
> ' After you have selected in Excel one or multiple charts or one or
> multiple areas start the macro
> ' "CreateSlidesFromSelection" . Then the macro will paste these
> selections as pictures
> ' in new or existing PP slides. By default new PP sildes will be
> created, by
> ' pressing the shift key you can make it paste to the ccurrently
> active slide, unless there is active slide. I'm
> ' starting this macro with a custom button on my custom toolbar.
> ' Works like a charm and is a great time saver if you have to create
> PP slides with Excel content frequently.
>
> '--------------------------------------------------------------------------------------------------------------------------------------
> Option Explicit
>
> Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey
> As Long) As Integer
>
> Function Key_pressed(key_to_check As Long) As Boolean
> If GetAsyncKeyState(key_to_check) And &H8000 Then
> Key_pressed = True
> Else
> Key_pressed = False
> End If
> End Function
>
> Sub CreateSlidesFromSelection()
> ''' COPY ONE OR MULTIPLE SELECTED EXCEL CHARTS OR SELECTED AREAS
> INTO POWERPOINT
> ' In the "tools" menu of the Visual Basic Editor set a reference to
> ' Microsoft PowerPoint Object Library
> Dim Sh As Shape
> Dim i As Integer
> Dim titel As String
> Dim new_slide As Boolean
> Dim half_size As Boolean
> Dim PasteSuccess As Boolean
>
>
> ' In case the shift key is pressed down while starting the macro
> ' the selection will be posted into an existing slide if available.
> ' if no slide or no presentation is open it will be created.
> new_slide = Not Key_pressed(vbKeyShift)
>
> ' In case the Control key is pressed down while starting the macro
> ' the selection will be posted on the right side of the slide with
> ' a smaller scaling to allow for text on the left side of the slide
> half_size = Key_pressed(vbKeyControl)
>
> On Error GoTo exitsub
> If Not ActiveChart Is Nothing Then ' one chart is selected
> On Error Resume Next
> titel = ActiveChart.ChartTitle.Characters.Text & " "
> titel = titel &
> ActiveChart.Axes(xlValue).AxisTitle.Characters.Text
> On Error GoTo 0
> ' Copy chart as a picture
> Application.ActiveChart.CopyPicture Appearance:=xlScreen,
> Size:=xlScreen, Format:=xlPicture
> Call PasteChart(new_slide, half_size, titel)
> PasteSuccess = True
> Else
> On Error Resume Next
> i = Selection.ShapeRange.Count 'if there is no error multiple
> charts are selected
> If err.Number = 0 Then ' err.number is zero because we have a
> multiple selection
> ' err.Clear
> On Error GoTo 0
> For Each Sh In Selection.ShapeRange
> If Sh.Type = msoChart Then ' IS SHAPE A CHART?
> Sh.Select
> Application.ActiveChart.CopyPicture
> Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
> titel = ""
> On Error Resume Next
> titel = ActiveChart.ChartTitle.Characters.Text & " "
> titel = titel &
> ActiveChart.Axes(xlValue).AxisTitle.Characters.Text
> On Error GoTo 0
> Call PasteChart(new_slide, half_size, titel)
> PasteSuccess = True
> End If
> Next
> Else ' in case no charts we might have one or more cell
> selections
> For i = 1 To Selection.Areas.Count
> If Selection.Areas(i).Cells.Count < 2 Then
> If MsgBox("You have selected a single cell." & Chr(10)
> & _
> "Should this single cell be copied to
> PowerPoint?", vbYesNo) = vbNo Then
> GoTo nextone
> End If
> End If
> Selection.Areas(i).Copy
> Call PasteChart(new_slide, half_size, titel)
> PasteSuccess = True
> Application.CutCopyMode = False
> nextone:
> Next i
> End If
> End If
> If PasteSuccess Then getPP.Activate
> ' Application.WindowState = xlMinimized
> exitsub:
> End Sub
> Private Sub PasteChart(newSlide As Boolean, toTheRight As Boolean,
> slideTitle As String)
> Dim PPApp As PowerPoint.Application
> Dim PPPres As PowerPoint.Presentation
> Dim PPSlide As PowerPoint.Slide
> Dim sID As Integer ' as slideindex
> Dim cScale As Single
> Dim ChartHeight As Integer
> Dim ChartWidth As Integer
>
> Set PPApp = getPP()
> Set PPPres = getPresentation(PPApp)
> On Error Resume Next
> If newSlide Then
> sID = 1
> sID = sID + PPApp.ActiveWindow.Selection.SlideRange.SlideIndex
> 'lets add below the actual one
> PPPres.Slides.Add sID, ppLayoutTitleOnly ' add a slide as #1
> or below the actual one
> Else
> sID = PPApp.ActiveWindow.Selection.SlideRange.SlideIndex 'is
> there a slide existing?
> If sID = 0 Then 'in case there is no slide
> sID = 1
> PPPres.Slides.Add sID, ppLayoutTitleOnly ' add a slide to
> the empty presentation
> End If
> End If
> On Error GoTo 0
> PPPres.Slides(sID).Select
> PPApp.ActiveWindow.ViewType = ppViewSlide
> Set PPSlide =
> PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
> PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
> ChartHeight = PPApp.ActiveWindow.Selection.ShapeRange.Height
> ChartWidth = PPApp.ActiveWindow.Selection.ShapeRange.Width
> If ChartWidth / ChartHeight > 1.75 Then
> cScale = 700 / ChartWidth
> Else
> cScale = 400 / ChartHeight
> End If
> If toTheRight Then ' Scale and Align pasted chart
> cScale = cScale / 1.5
> With PPApp.ActiveWindow.Selection.ShapeRange
> .ScaleWidth cScale, msoFalse, msoScaleFromTopLeft
> .ScaleHeight cScale, msoFalse, msoScaleFromBottomRight
> .Align msoAlignRights, True
> .Align msoAlignMiddles, True
> .IncrementLeft -25#
> End With
> Else
> With PPApp.ActiveWindow.Selection.ShapeRange
> .ScaleWidth cScale, msoFalse, msoScaleFromTopLeft
> .ScaleHeight cScale, msoFalse, msoScaleFromBottomRight
> .Align msoAlignCenters, True
> .Align msoAlignMiddles, True
> .IncrementTop 12#
> End With
> End If
>
> PPApp.ActiveWindow.ViewType = ppViewNormal
> If PPSlide.Shapes.title.TextFrame.TextRange.Text = "" Then 'set
> title in case there is none already
> PPSlide.Shapes.title.TextFrame.TextRange.Text = slideTitle
> End If
>
> Set PPSlide = Nothing
> Set PPPres = Nothing
> Set PPApp = Nothing
> End Sub
> Private Function getPP() As PowerPoint.Application
> On Error Resume Next
> Set getPP = GetObject("Powerpoint.Application")
> If err.Number <> 0 Then ' iff PP isn't there lets start it
> Set getPP = CreateObject("Powerpoint.Application")
> err.Clear
> End If
> getPP.Visible = msoCTrue
> End Function
> Private Function getPresentation(PPApp As PowerPoint.Application) As
> PowerPoint.Presentation
> ' Reference active presentation
> On Error Resume Next
> Set getPresentation = PPApp.ActivePresentation
> If err.Number <> 0 Then 'if no presentation lets create one
> Set getPresentation = PPApp.Presentations.Add(True)
> err.Clear
> End If
> End Function
>