• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Copy paste range from excel to ppt as a bitmap - VBA help [SOLVED]

S

sam77

New Member
Hi,


I need to copy paste a range as a bitmap from excel to ppt. I have a code which copies individual graphs into seperate slides as bitmap images, however would need a code to copy a range. Could any one help. Would you need the code that i have.


Regards,

Sam
 
Here is the code... that i have.... i got it from Chandoo.org itself... can anyone tweak it to a copy range...


Sub CreatePowerPoint()


'Add a reference to the Microsoft PowerPoint Library by:

'1. Go to Tools in the VBA menu

'2. Click on Reference

'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay


'First we declare the variables we will be using

Dim newPowerPoint As PowerPoint.Application

Dim activeSlide As PowerPoint.slide

Dim cht As Excel.ChartObject


'Look for existing instance

On Error Resume Next

Set newPowerPoint = GetObject(, "PowerPoint.Application")

On Error GoTo 0


'Let's create a new PowerPoint

If newPowerPoint Is Nothing Then

Set newPowerPoint = New PowerPoint.Application

End If

'Make a presentation in PowerPoint

If newPowerPoint.Presentations.Count = 0 Then

newPowerPoint.Presentations.Add

End If


'Show the PowerPoint

newPowerPoint.Visible = True


'Loop through each chart in the Excel worksheet and paste them into the PowerPoint

For Each cht In ActiveSheet.ChartObjects


'Add a new slide where we will paste the chart

newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText

newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count

Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)


'Copy the chart and paste it into the PowerPoint as a Metafile Picture

cht.Select

ActiveChart.ChartArea.Copy

activeSlide.Shapes.PasteSpecial(DataType:=xlBitmap).Select


'Set the title of the slide the same as the title of the chart

activeSlide.Shapes(1).TextFrame.TextRange.text = cht.Chart.ChartTitle.text


'Adjust the positioning of the Chart on Powerpoint Slide

newPowerPoint.ActiveWindow.selection.ShapeRange.Left = 15

newPowerPoint.ActiveWindow.selection.ShapeRange.Top = 125


activeSlide.Shapes(2).Width = 200

activeSlide.Shapes(2).Left = 505


'If the chart is the "US" consumption chart, then enter the appropriate comments

If InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "US") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J7").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)

'Else if the chart is the "Renewable" consumption chart, then enter the appropriate comments

ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "Renewable") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J27").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)

End If


'Now let's change the font size of the callouts box

activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16


Next


AppActivate ("Microsoft PowerPoint")

Set activeSlide = Nothing

Set newPowerPoint = Nothing


End Sub
 
Sub CreatePowerPoint()


'Add a reference to the Microsoft PowerPoint Library by:

'1. Go to Tools in the VBA menu

'2. Click on Reference

'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay


'First we declare the variables we will be using

Dim newPowerPoint As PowerPoint.Application

Dim activeSlide As PowerPoint.slide

Dim cht As Excel.ChartObject


'Look for existing instance

On Error Resume Next

Set newPowerPoint = GetObject(, "PowerPoint.Application")

On Error GoTo 0


'Let's create a new PowerPoint

If newPowerPoint Is Nothing Then

Set newPowerPoint = New PowerPoint.Application

End If

'Make a presentation in PowerPoint

If newPowerPoint.Presentations.Count = 0 Then

newPowerPoint.Presentations.Add

End If


'Show the PowerPoint

newPowerPoint.Visible = True


'Loop through each chart in the Excel worksheet and paste them into the PowerPoint

For Each cht In ActiveSheet.ChartObjects


'Add a new slide where we will paste the chart

newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText

newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count

Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)


'Copy the chart and paste it into the PowerPoint as a Metafile Picture

cht.Select

ActiveChart.ChartArea.Copy

activeSlide.Shapes.PasteSpecial(DataType:=xlBitmap).Select


'Set the title of the slide the same as the title of the chart

activeSlide.Shapes(1).TextFrame.TextRange.text = cht.Chart.ChartTitle.text


'Adjust the positioning of the Chart on Powerpoint Slide

newPowerPoint.ActiveWindow.selection.ShapeRange.Left = 15

newPowerPoint.ActiveWindow.selection.ShapeRange.Top = 125


activeSlide.Shapes(2).Width = 200

activeSlide.Shapes(2).Left = 505


'If the chart is the "US" consumption chart, then enter the appropriate comments

If InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "US") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J7").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)

'Else if the chart is the "Renewable" consumption chart, then enter the appropriate comments

ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "Renewable") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J27").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)

End If


'Now let's change the font size of the callouts box

activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16


Next


AppActivate ("Microsoft PowerPoint")

Set activeSlide = Nothing

Set newPowerPoint = Nothing


End Sub
 
Sub CreatePowerPoint()


Dim newPowerPoint As PowerPoint.Application

Dim activeSlide As PowerPoint.slide

Dim cht As Excel.ChartObject

On Error Resume Next

Set newPowerPoint = GetObject(, "PowerPoint.Application")

On Error GoTo 0


If newPowerPoint Is Nothing Then

Set newPowerPoint = New PowerPoint.Application

End If


If newPowerPoint.Presentations.Count = 0 Then

newPowerPoint.Presentations.Add

End If


newPowerPoint.Visible = True


For Each cht In ActiveSheet.ChartObjects


newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText

newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count

Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)


cht.Select

ActiveChart.ChartArea.Copy

activeSlide.Shapes.PasteSpecial(DataType:=xlBitmap).Select


activeSlide.Shapes(1).TextFrame.TextRange.text = cht.Chart.ChartTitle.text


newPowerPoint.ActiveWindow.selection.ShapeRange.Left = 15

newPowerPoint.ActiveWindow.selection.ShapeRange.Top = 125


activeSlide.Shapes(2).Width = 200

activeSlide.Shapes(2).Left = 505


If InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "US") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J7").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)


ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "Renewable") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J27").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)

End If


activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16


Next


AppActivate ("Microsoft PowerPoint")

Set activeSlide = Nothing

Set newPowerPoint = Nothing


End Sub
 
Sub CreatePowerPoint()


Dim newPowerPoint As PowerPoint.Application

Dim activeSlide As PowerPoint.slide

Dim cht As Excel.ChartObject

On Error Resume Next

Set newPowerPoint = GetObject(, "PowerPoint.Application")

On Error GoTo 0


If newPowerPoint Is Nothing Then

Set newPowerPoint = New PowerPoint.Application

End If


If newPowerPoint.Presentations.Count = 0 Then

newPowerPoint.Presentations.Add

End If


newPowerPoint.Visible = True


For Each cht In ActiveSheet.ChartObjects


newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText

newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count

Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)


cht.Select

ActiveChart.ChartArea.Copy

activeSlide.Shapes.PasteSpecial(DataType:=xlBitmap).Select


activeSlide.Shapes(1).TextFrame.TextRange.text = cht.Chart.ChartTitle.text


newPowerPoint.ActiveWindow.selection.ShapeRange.Left = 15

newPowerPoint.ActiveWindow.selection.ShapeRange.Top = 125


activeSlide.Shapes(2).Width = 200

activeSlide.Shapes(2).Left = 505


If InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "US") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J7").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)


ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.text, "Renewable") Then

activeSlide.Shapes(2).TextFrame.TextRange.text = Range("J27").Value & vbNewLine

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)

activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)

End If

activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16

Next

AppActivate ("Microsoft PowerPoint")

Set activeSlide = Nothing

Set newPowerPoint = Nothing

End Sub
 
I can't code it out for you, but maybe I could give you a start.


You could copy the range you want, then paste+special as a picture. Then, select the picture, copy it, then paste in your ppt.


You could record this in the macro recorder, then substitute the necessary pieces into the code you already have for graphs.


Good luck!
 
Hi Sam ,


Have you tried this ?

[pre]
Code: 
Public Sub pickup()
Dim XLApp As Excel.Application
Dim PPSlide As Slide
Set XLApp = GetObject(, "Excel.Application")
XLApp.Range("A1").Select
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set PPSlide = ActivePresentation.Slides.Add(1, ppLayoutObject)
PPSlide.Shapes.Paste
End Sub
[/pre]
This is in a VB module in your Powerpoint presentation. Your Excel workbook should be open when you run this , otherwise the file's path should be specified in the GetObject function , as the first parameter.


Narayan
 
You must log in or register to reply here.
Back
Top