PDA

View Full Version : [SOLVED] Macro for copying flexible ranges as pictures to PPT



RandomGerman
05-19-2017, 09:52 AM
Dear all,

I have a few experiences in coding VBA for PowerPoint, but this is the first time I have a need in VBA for Excel. (And the first time I'm posting in the Excel section of this helpful forum. Hello to all! :-) )
As VBA for PowerPoint and for Excel might be brothers, but not twins, some of my pieces of code work and others don't.

I am looking for a macro to copy ranges from Excel and paste them as pictures to PowerPoint. I found something Chris (the spreadsheetguru) wrote, which is very close to what I want to do.

I tried two modifications.

The first was an Input box, giving the user the chance to define the range of cells by himself. This part seems to work.

The second: I want to paste to the active slide, not add a new one, which is, what actually happens.


This is where I stand, please have a look at the comments:


Option Explicit
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range To The Active PowerPoint Slide
'SOURCE: Most of it: www.TheSpreadsheetGuru.com (http://www.TheSpreadsheetGuru.com) - few modifications: Me. :-)
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim Message As String
Dim Title As String
Dim Default As String
Dim myValue As String

Message = "Please enter Range of cells you want to transfer" & vbCrLf & "Examples:" & vbCrLf & "A1:C10 - for a range" & vbCrLf & "or: F42 - for one cell"
Title = "Transfer to PowerPoint - Input box"
Default = "A1:C10"
myValue = InputBox(Message, Title, Default)

'Handles if User cancels
On Error GoTo UserCancels

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range(myValue)

'Create an Instance of PowerPoint
On Error Resume Next

'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0

'Optimize Code
Application.ScreenUpdating = False

'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation

'The next line of code is not what I want.
'I want to define mySlide as the active slide.
'I tried: Set mySlide = ActiveWindow.View.Slide <= Would work in PPT, but in Excel debugging didn't accept it

'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False

Exit Sub

UserCancels:
Exit Sub

End Sub


Finally, I need help for three points:
1. A solution for the active slide problem (marked with a Long comment in the code)
2. An error message in the right moment, in case no PowerPoint presentation is open
3. As there are some parts in Chris' code I must admit I don't understand, I have no idea if they are still necessary after all modifications. Please feel free to optimize and/or clean up anything you see. If there is room for improvement, please improve. :-)


Thanks a lot in advance
RG

mdmackillop
05-19-2017, 10:51 AM
You can refer to a SlideNumber but I don't know how to get this in PP for the active slide.

Set mySlide = myPresentation.Slides(2)

Edit:
I found this suggested here (https://answers.microsoft.com/en-us/msoffice/forum/msoffice_powerpoint-mso_other/in-powerpoint-vba-how-do-i-refer-to-the-active/5b4a7daf-9309-4159-b648-586d75895f85)

Set mySlide = PowerPointApp.ActiveWindow.View.Slide



Warning code

'Create a New Presentation
On Error Resume Next
Set myPresentation = PowerPointApp.ActivePresentation
If Err <> 0 Then
MsgBox "No open presentation", vbCritical
Exit Sub
End If
On Error GoTo 0

RandomGerman
05-19-2017, 11:41 AM
Set mySlide = PowerPointApp.ActiveWindow.View.Slide

This makes abolute sense. It is exactly the code working in PowerPoint - it is only necessary first to define, that it has to be done in PowerPoint.

Thank you very much, and for the warning code, too. Works great.

mdmackillop
05-19-2017, 11:57 AM
I've incorporated the above and reordered some of the events.
If no presentation is active, the code will stop at an open PP allowing you to select your presentation and slide. Excel will be reduced to "Normal" size.
Rerunning the code will add the image to the active slide.

Either Select object to be copied or be prompted for range.


Option ExplicitSub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range To The Active PowerPoint Slide
'SOURCE: Most of it: www.TheSpreadsheetGuru.com (http://www.TheSpreadsheetGuru.com) - few modifications: Me. :-)
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim Message As String
Dim Title As String
Dim Default As String
Dim myValue As String
Dim Typ As String

'Is PowerPoint already opened?
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Open Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'If no active presentation
If Err <> 0 Then
'Normalise Excel window and make PowerPoint Visible and Active to choose Presentation
ActiveWindow.WindowState = xlNormal
PowerPointApp.Visible = True
PowerPointApp.Activate
Exit Sub
End If
On Error GoTo 0

Typ = TypeName(Selection)
If Typ = "Range" Then
Message = "Please enter Range of cells you want to transfer" & vbCrLf & "Examples:" & vbCrLf & "A1:C10 - for a range" & vbCrLf & "or: F42 - for one cell"
Title = "Transfer to PowerPoint - Input box"
Default = "A1:P30"
myValue = InputBox(Message, Title, Default)
'Handles if User cancels
On Error GoTo UserCancels
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range(myValue)
'Optimize Code
Application.ScreenUpdating = False
'Copy Excel Range
rng.Copy
Else
Selection.Copy
End If

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Set mySlide = myPresentation.Slides(2)
Set mySlide = PowerPointApp.ActiveWindow.View.Slide
'Paste to PowerPoint and position

If Typ = "ChartArea" Then
mySlide.Shapes.PasteSpecial DataType:=6 '6= ppPastePNG
Else
mySlide.Shapes.PasteSpecial DataType:=2 '2= ppPasteEnhancedMetafile
End If

Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
'Clear The Clipboard
Application.CutCopyMode = False
UserCancels:
Exit Sub
End Sub

RandomGerman
05-20-2017, 06:02 AM
Wow, this is really impressive! Thank you for the time to improve the macro! I think this version is helpful for anybody who has to transfer a lot of data from Excel to PPT.