Re: How do I copy and paste a powerpoint slide from excel using vba co
JP
Either way, you'll probably need to know some PowerPoint VBA.
HTH,
JP
"LilacSpokane" <LilacS...@discussions.microsoft.com> wrote in message
news:B46CD1B1-9260-4F41...@microsoft.com...
> How do I copy and paste a powerpoint slide from excel using vba code
minimaster
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
ryguy7272
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/photosgraphicsclipart/ss/070805excelchrt_3.htm
I've used this technique with great success!!
Regards,
Ryan---
--
RyGuy