-
Hi All,
Here is a routine which helps you to copy paste a range or chart into power point.
Copy the entire code and paste into a new Standard module.
Code:
Public Enum PasteFormat
xl_Link = 0
xl_HTML = 1
xl_Bitmap = 2
End Enum
Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)
' Modified version of code originally posted here:
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=370
' Modified by : Krishnakumar @ ExcelFox.com
' Used Late binding so that no issues when users have multiple Excel version
Dim PasteRange As Boolean
Dim objChart As ChartObject
Dim lngSU As Long
Select Case TypeName(PasteObject)
Case "Range"
If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
PasteRange = True
Case "Chart": Set objChart = PasteObject.Parent
Case "ChartObject": Set objChart = PasteObject
Case Else
MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
Exit Sub
End Select
With Application
lngSU = .ScreenUpdating
.ScreenUpdating = 0
End With
ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber
On Error GoTo -1: On Error GoTo 0
DoEvents
If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture Appearance:=1, Format:=-4147
ppSlide.Shapes.Paste.Select
ElseIf Paste_Type = xl_HTML Then
'//Paste Range as HTML
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(8, link:=1).Select 'ppPasteHTML
ElseIf Paste_Type = xl_Link Then
'//Paste Range as Linked
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(0, link:=1).Select 'ppPasteDefault
End If
Else
If Paste_Type = xl_Link Then
'//Copy & Paste Chart Linked
objChart.Chart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'//Copy & Paste Chart Not Linked
objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
ppSlide.Shapes.Paste.Select
End If
End If
'//Center pasted object in the slide
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
With Application
.CutCopyMode = False
.ScreenUpdating = lngSU
End With
AppActivate ("Microsoft Excel")
End Sub
An example sub to call the routine
Code:
Sub kTest()
Dim ppApp As Object
Dim ppSlide As Object
On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
On Error GoTo 0
If ppApp Is Nothing Then
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = True
ppApp.presentations.Add
End If
If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
Else
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
End If
'//or you could specify the slide number. e.g. for the second slide
'Set ppSlide = ppApp.ActivePresentation.Slides(2)
Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.ChartObjects(1).Chart, xl_Bitmap
'//Range
'Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.Range("A1:J6"), xl_Bitmap
End Sub
-
Revised routine, with excel image adjustment in powerpoint slide.
Code:
Public Enum PasteFormat
xl_Link = 0
xl_HTML = 1
xl_Bitmap = 2
End Enum
Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)
' Modified by : LalitMohan @ ExcelFox.com
Dim PasteRange As Boolean
Dim objChart As ChartObject
Select Case TypeName(PasteObject)
Case "Range"
If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
PasteRange = True
Case "Chart": Set objChart = PasteObject.Parent
Case "ChartObject": Set objChart = PasteObject
Case Else
MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
Exit Sub
End Select
ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber
On Error GoTo -1: On Error GoTo 0
DoEvents
If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture Appearance:=1, Format:=-4147
ppSlide.Shapes.Paste.Select
ElseIf Paste_Type = xl_HTML Then
'//Paste Range as HTML
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(8, link:=1).Select 'ppPasteHTML
ElseIf Paste_Type = xl_Link Then
'//Paste Range as Linked
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(0, link:=1).Select 'ppPasteDefault
End If
Else
If Paste_Type = xl_Link Then
'//Copy & Paste Chart Linked
objChart.Chart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'//Copy & Paste Chart Not Linked
objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
ppSlide.Shapes.Paste.Select
End If
End If
'//Center pasted object in the slide
With ppApp.ActiveWindow.Selection.ShapeRange
.LockAspectRatio = False
.Height = ppSlide.Parent.PageSetup.SlideHeight * 0.98
.LockAspectRatio = False
.Width = ppSlide.Parent.PageSetup.SlideWidth * 0.98
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With
Call AppActivate("Microsoft Excel")
PasteRange = Empty
Set objChart = Nothing
End Sub
Example sub to call this routine
Code:
Sub LalitTest()
Dim ppApp As Object
Dim ppSlide As Object
Application.ScreenUpdating = False
On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
On Error GoTo -1: On Error GoTo 0: Err.Clear
If ppApp Is Nothing Then
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = True
ppApp.presentations.Add
End If
If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
Else
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
End If
Call Copy_Paste_to_PowerPoint(ppApp, ppSlide, ActiveSheet.Range("Print_Area"), xl_Bitmap)
Application.ScreenUpdating = True
Set ppApp = Nothing
Set ppSlide = Nothing
End Sub
