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" wrote in message
...
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.Tex t
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.Tex t
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.SlideRa nge.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 he
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.Tex t
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.Tex t
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.SlideRa nge.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.Tex t
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.Tex t
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.SlideRa nge.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