Sayfadaki Tum Chartlari Powerpoint’e Yapistirma

ppt

kod icerisine ilgili bolumlerin iceriklerini eklesemde herhangi bir tema secmek isterseniz yorum ile kapatilmis bir kod satiri oldugunu hatirlatmak isterim.

 

Sub export_to_ppt()
'Referanslardan Microsoft Outlook eklenmeli
Dim PPApp           As PowerPoint.Application
Dim PPPres          As PowerPoint.Presentation
Dim PPSlide         As PowerPoint.slide
Dim SlideCount      As Integer
Dim shp             As Shape

    Set PPApp = New PowerPoint.Application
    PPApp.Visible = True
    'Yeni ppt Olustur
    Set PPPres = PPApp.Presentations.Add

    'Slide temasini Belirle
'PPPres.ApplyTemplate Filename:="C:.....thmx" ' Tema secmek isterseniz yorumu kaldirarak temanizin dizinini belirtiniz
    'Chartlarda Dongu
    For Each shp In Sheets(1).Shapes
        If shp.Type = msoChart Then

             SlideCount = PPPres.Slides.Count
             Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
             'Baslik Ekle
             PPSlide.Shapes(1).TextFrame.TextRange.Text = shp.Chart.ChartTitle.Text ' add chart title as header
             'Baslik Formati
             With PPSlide.Shapes(1).TextFrame.TextRange.Characters
                 .Font.Size = 30
                 .Font.Name = "Arial"
                 .Font.Color = vbWhite
             End With

             With PPSlide.Shapes(1)
                 .Fill.BackColor.RGB = RGB(79, 129, 189)
                 .Height = 50
                 .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft ' left align the header text
             End With

             shp.Chart.ChartArea.Copy ' Chart Kopyala
             PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex ' Slide aktiflestir
             PPSlide.Shapes.Paste.Select ' Yapistir
             'Chart'in slide icindeki yeri
             PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
             PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
         End If
     Next

    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing

End Sub

PPT Olustur

Yazar: mmustafaaslan

2004 yilindan itibaren ozel bir sirketin finans departmaninda calismaktadir. Kendini excel, visual basic kullaniminda gelistirmis olan yazarimiz; Meslegi geregi SAP konusunda ileri derecede bilgilidir.

Bir Cevap Yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir


8 + 8 =