Sub
AllChartsToPowerPoint()
Dim
ppApp
As
PowerPoint.Application
Dim
xlChart
As
Excel.Chart
Dim
xlWB
As
New
Excel.Workbook
Dim
intWB
As
Integer
Dim
intCtWBs
As
Integer
Dim
intChart
As
Integer
Dim
intCtCharts
As
Integer
intCtWBs = Workbooks.Count
Set
ppApp =
New
PowerPoint.Application
With
ppApp
.Visible =
True
.Activate
.Presentations.Open (
"\\emea.baumernet.org\de01d\Templates\All\B_PPT_Confidential_ONLY_internal_use.potx"
)
For
intWB = 1
To
intCtWBs
intCtCharts = Workbooks(intWB).Charts.Count
For
intChart = 1
To
intCtCharts
Set
xlChart = Workbooks(intWB).Charts(intChart)
xlChart.ChartArea.Copy
With
.ActivePresentation
.Slides(3).Shapes.PasteSpecial ppPasteBitmap
With
.Slides(3).Shapes.Range
.Height = 300
.Width = 600
.Left = 60
.Top = 85
End
With
End
With
Next
Next
End
With
Set
ppApp =
Nothing
End
Sub