Copy Chart from Excel to Powerpoint Pres

P

Paul Cook

Here is what I am doing:
1) Automated Excel to pull data from DB2 and created charts
2) Need to take charts from Excel and place them into a
powerpoint presentation.

If someone can point me in the right direction to get this
done it would be greatly appreciated.

Paul

I have a master powerpoint presentation that I add slides
to and format to ppLayoutFourObjects. I need to get the
charts from Excel and place them in the correct "object"
on the sheet.

Here is the code that I have: (It will create an Excel
worksheet and fill in some test data, create a chart, then
open my Powerpoint master, add slides.

Option Explicit

Dim xlApp As Object
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation

Public Sub main()
Dim r As Variant
Dim MyChart As String
Dim iWhereAt As Integer
Const sLookFor = " "


Call LoadExcel
Call FillData
MyChart = BuildChart

iWhereAt = InStr(1, MyChart, sLookFor) + 1
MyChart = Mid(MyChart, iWhereAt)




Call ClearClipboard

Call LoadPP
Call CopyChart(MyChart)
xlBook.Activate
xlBook.Sheets(1).Select

End Sub

Public Sub LoadPP()
Dim MyTest
Dim y As Integer

Set ppApp = New PowerPoint.Application
ppApp.Visible = msoTrue
Set ppPres = ppApp.Presentations.Open("C:\SSP\SSP
Yield Master.ppt")

Call AddTestSlide(ppApp)
For y = 2 To 6
ppApp.ActiveWindow.View.GotoSlide Index:=y
Call TitleSlide(ppApp, y)
Next

ppApp.ActiveWindow.View.GotoSlide Index:=2
End Sub

Public Sub AddTestSlide(ppCurApp As PowerPoint.Application)
Dim sldNewSlide As PowerPoint.Slide
Dim shpCurrShape As PowerPoint.Shape
Dim lngSlideHeight As Long
Dim lngSlideWidth As Long
Dim x As Integer

With ppCurApp.ActivePresentation
With .PageSetup
lngSlideHeight = .SlideHeight
lngSlideWidth = .SlideWidth
End With
' Add new slide to end of presentation
For x = 1 To 5
Set sldNewSlide = .Slides.Add(.Slides.Count +
1, ppLayoutFourObjects)
Next
End With
End Sub

Public Sub TitleSlide(ppCurApp As PowerPoint.Application,
iSlide As Integer)

ppCurApp.ActiveWindow.Selection.SlideRange.Shapes
("Rectangle 2").Select

ppCurApp.ActiveWindow.Selection.ShapeRange.TextFrame.TextRa
nge.Select

ppCurApp.ActiveWindow.Selection.ShapeRange.TextFrame.TextRa
nge.Characters(Start:=1, Length:=0).Select
With ppCurApp.ActiveWindow.Selection.TextRange
If iSlide >= 2 And iSlide <= 3 Then
.Text = "Single Slider Yields"
ElseIf iSlide >= 4 And iSlide <= 6 Then
.Text = "Yield Summary"
End If
With .Font
.Name = "Arial"
.NameOther = "Arial"
.Size = 34
.Bold = msoTrue
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoTrue
.Color.SchemeColor = ppTitle
End With
End With
End Sub

Public Sub CopyChart(sCurrChartName As String)
ActiveSheet.ChartObjects(sCurrChartName).Activate
ActiveChart.ChartArea.Select

xlBook.Worksheets(1).ChartObjects(1).CopyPicture

ppPres.Slides(2).Shapes.PasteSpecial (ppPasteDefault)

'ActiveChart.ChartArea.Copy
End Sub

Public Sub ClearClipboard()
Clipboard.Clear
End Sub

Public Sub FillData()
Sheets(1).Cells(2, 2).Value = "A"
Sheets(1).Cells(3, 2).Value = "B"
Sheets(1).Cells(4, 2).Value = "C"
Sheets(1).Cells(5, 2).Value = "D"
Sheets(1).Cells(6, 2).Value = "E"
Sheets(1).Cells(7, 2).Value = "F"
Sheets(1).Cells(8, 2).Value = "G"
Sheets(1).Cells(2, 3).Value = 15
Sheets(1).Cells(3, 3).Value = 5
Sheets(1).Cells(4, 3).Value = 8
Sheets(1).Cells(5, 3).Value = 2
Sheets(1).Cells(6, 3).Value = 17
Sheets(1).Cells(7, 3).Value = 3
Sheets(1).Cells(8, 3).Value = 10
End Sub

Public Sub LoadExcel()
Dim iSheetsInWB As Integer
Dim iSheetsToAdd As Integer
Dim iAddIter As Integer

Set xlApp = CreateObject("excel.application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
iSheetsInWB = xlBook.Sheets.Count
If iSheetsInWB < 1 Then
iSheetsToAdd = 3 - iSheetsInWB
For iAddIter = 1 To iSheetsToAdd
xlBook.Sheets.Add After:=xlBook.Worksheets
(xlBook.Worksheets.Count)
Next
End If
xlBook.Sheets(1).Select
Set xlSheet = xlBook.Sheets(iSheetsInWB)
End Sub

Public Function BuildChart() As String
Dim sChartName As String
Range("B2:C8").Select
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Sheets
("Sheet1").Range("B2:C8"), PlotBy _
:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject,
Name:="Sheet1"
With ActiveChart
.HasTitle = False
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
ActiveChart.Legend.Select
Selection.Delete
ActiveChart.PlotArea.Select
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Interior.ColorIndex = xlNone
ActiveChart.ChartArea.Select
sChartName = ActiveChart.Name
BuildChart = sChartName
End Function
 
P

Paul Cook

Actually I just figured it out....

Public Sub CopyChart(iSheetNum as integer, sCurrChartName
As String, sWhereInSlide as string)
ActiveSheet.ChartObjects(sCurrChartName).Activate
ActiveChart.ChartArea.Select

xlBook.Worksheets(iSheetNum).ChartObjects
(sCurrChartName).Copy


ppApp.ActiveWindow.Selection.SlideRange.Shapes
(sWhereInSlide).Select
ppApp.ActiveWindow.View.Paste

End Sub


And it works.....

Paul
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top