hirak99

Function AddSlide(Title$) As PowerPoint.Slide
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewNormal
SlideCount% = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
PPSlide.Shapes("Rectangle 2").TextFrame.TextRange = Title
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set AddSlide = PPSlide
End Function

Sub ChartsAndTitlesToPresentation(PPSlide As PowerPoint.Slide, ChartObject As Chart, Position%)

Dim PPApp As PowerPoint.Application
Set PPApp = GetObject(, "Powerpoint.Application")

Dim top_indent(4), left_indent(4) As Double
left_indent(0) = 96
left_indent(1) = 341
left_indent(2) = 36
left_indent(3) = 341
top_indent(0) = 102
top_indent(1) = 108
top_indent(2) = 270
top_indent(3) = 270
    
    'ChartObject.CopyPicture appearance:=xlScreen, Format:=xlPicture
    ChartObject.ChartArea.Copy
     'With Selection
                 ' copy chart as a picture
      '           .CopyPicture
                ' .CopyPicture _
                 '    Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
     
                 ' restore title
     'End With
    
     With PPSlide
         ' paste and select the chart picture
         .Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
         ' align the chart
         PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
         PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
         With PPApp.ActiveWindow.Selection.ShapeRange
                     .LockAspectRatio = msoFalse
                     .Width = 564
                     .Height = 360
                     .left = left_indent(Position)
                     .top = top_indent(Position)
         End With
     End With
End Sub

Function GetChartByName(ChartName$) As Chart
Dim ch As Chart
For i% = 1 To ActiveSheet.ChartObjects.Count
    Set ch = ActiveSheet.ChartObjects(i).Chart
    If Trim(ch.ChartTitle.Text) = Trim(ChartName) Then
        Set GetChartByName = ch
    End If
Next
End Function

Sub AddChart(PPSlide As PowerPoint.Slide, Position%, ChartName$)
    Dim ch As Chart
    Set ch = GetChartByName(ChartName$)
    ch.HasLegend = False
    ChartsAndTitlesToPresentation PPSlide, ch, Position
End Sub

Sub ToPowerpoint()
    Sheets("Charts").Select
    Dim PPSlide As PowerPoint.Slide
    For i% = 1 To ActiveSheet.ChartObjects.Count
        Set PPSlide = AddSlide(ActiveSheet.ChartObjects(i).Chart.ChartTitle.Text)
        ChartsAndTitlesToPresentation PPSlide, ActiveSheet.ChartObjects(i).Chart, 0
    Next
End Sub