Code:
Option Explicit
'------------------
' optionnal
' To add reference to PowerPoint Library when tools > references not available.
'
Sub AddReReference()
ThisWorkbook.VBProject.References.AddFromFile _
"C:\Program Files (x86)\Microsoft Office\Office14\MSppt.OLB"
End Sub
'------------------
'---------------------------------------------------------------------------------------
' Procedure : GetFileName
' Author
' Date : 7/29/2013
' Purpose :
'---------------------------------------------------------------------------------------
'
Function GetFileName() As String
Dim strNewFN As String
On Error GoTo GetFileName_Error
'FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file"
strNewFN = Application.GetOpenFilename()
GetFileName = strNewFN
On Error GoTo 0
Exit Function
GetFileName_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetFileName of Module Module3 On Line " & Erl
End Function
' Code to export data, charts, etc.
'---------------------------------------------------------------------------------------
' Procedure : PopulatePowerPoint
' Author :
' Date : 7/29/2013
' Purpose :
'---------------------------------------------------------------------------------------
'
Sub PopulatePowerPoint()
'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 ppSlide As PowerPoint.Slide
Dim strPlaceHolder As String
Dim strPowerPointFileName As String
Dim wsWorksheets As Excel.Worksheet
Dim choCharts As Excel.ChartObject
Dim ppApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim cht As Excel.ChartObject
On Error GoTo PopulatePowerPoint_Error
'Get PPT file name
strPowerPointFileName = GetFileName
'Open PPT
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = msoTrue
Set PPPres = ppApp.Presentations.Open(strPowerPointFileName)
ppApp.ActiveWindow.ViewType = ppViewSlide
'Call function to add selected chart in the PPT
' Arguments are: PPTFile, ChartObject, Top, Left, Width, Height
' Ajust position and dimensions as required.
'Chart no1
Set cht = ThisWorkbook.Sheets("Dept Lines").ChartObjects("Chart 1")
Call ChartsToPPT(PPPres, 3, cht, 100, 100, 100, 300)
'Chart no2
Set cht = ThisWorkbook.Sheets("Dept Lines").ChartObjects("Chart 2")
Call ChartsToPPT(PPPres, 4, cht, 100, 150, 200, 350)
'Chart no3
Set cht = ThisWorkbook.Sheets("Qty Per Line Shipped").ChartObjects("Chart 1")
Call ChartsToPPT(PPPres, 5, cht, 125, 100, 300, 300)
'Chart no4
Set cht = ThisWorkbook.Sheets("UM Analysis").ChartObjects("Chart 1")
Call ChartsToPPT(PPPres, 6, cht, 150, 400, 300, 300)
'Chart no5
Set cht = ThisWorkbook.Sheets("Qty Per Line Shipped").ChartObjects("Chart 2")
Call ChartsToPPT(PPPres, 6, cht, 150, 10, 300, 300)
'Chart no6
Set cht = ThisWorkbook.Sheets("UM Analysis").ChartObjects("Chart 2")
Call ChartsToPPT(PPPres, 7, cht, 150, 350, 300, 300)
'Chart no7
Set cht = ThisWorkbook.Sheets("Qty Per Line Shipped").ChartObjects("Chart 3")
Call ChartsToPPT(PPPres, 7, cht, 150, 10, 300, 300)
'Chart no8
Set cht = ThisWorkbook.Sheets("UM Analysis").ChartObjects("Chart 3")
Call ChartsToPPT(PPPres, 8, cht, 150, 350, 300, 300)
'Chart no9
Set cht = ThisWorkbook.Sheets("Qty Per Line Shipped").ChartObjects("Chart 4")
Call ChartsToPPT(PPPres, 8, cht, 150, 10, 300, 300)
On Error GoTo 0
CleanUp:
Set cht = Nothing
Set PPPres = Nothing
Set ppSlide = Nothing
Set ppApp = Nothing
Exit Sub
PopulatePowerPoint_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PopulatePowerPoint of Module Module3 On Line " & Erl
GoTo CleanUp
End Sub
' Code to copy selected chart to specified slide.
Sub ChartsToPPT(oPPT As PowerPoint.Presentation, iSlideNo As Integer, _
cht As ChartObject, iTop As Integer, iLeft As Integer, iWidth As Integer, iHeight As Integer)
Dim ppSlide As PowerPoint.Slide
Dim pSh As PowerPoint.Shape
'Select slide
Set ppSlide = oPPT.Slides(iSlideNo)
'cht.Copy
cht.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
With ppSlide
.Shapes.Paste
'.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
Set pSh = .Shapes(.Shapes.Count) '.Select 'Select the last shape
End With
With pSh
.Top = iTop
.Left = iLeft
.Width = iWidth
.Height = iHeight
End With
End Sub
Reply With Quote
Bookmarks