Bu bölümde Excel sayfalarını mevcut bir PowerPoint sunumuna eklemeyi veya bu sayfalardan yeni bir PowerPoint sunumu oluşturmayı öğreneceğiz.
PowerPoint açıksa slaytlar en sona eklenir, PowerPoint kapalıysa yeni bir sunum dosyası oluşturulur.
Not: Sayfa düzeninin PowerPoint için optimize edilmesi gereklidir.
Bu örnekte Early Binding metodu kullanılacaktır.
Sub PowerPoint_Sunum_Yaratma() Dim PPuygulama As PowerPoint.Application Dim PPsunum As PowerPoint.Presentation Dim PPslayt As PowerPoint.Slide Dim PPsekil As PowerPoint.Shape Dim PPtasarim As PowerPoint.CustomLayout Dim KopyalanacakAlan As Range Dim Sayfa As Worksheet Dim i As Long 'slayt sayacı Application.ScreenUpdating = False On Error Resume Next Set PPuygulama = GetObject(, "Powerpoint.Application") On Error GoTo 0 If PPuygulama Is Nothing Then 'eğer açılmıyorsa yeni bir powerpoint oturumu aç Set PPuygulama = New PowerPoint.Application End If If PPuygulama.Presentations.Count = 0 Then Set PPsunum = PPuygulama.Presentations.Add i = 0 Else Set PPsunum = PPuygulama.ActivePresentation i = PPsunum.Slides.Count End If Set PPtasarim = PPsunum.SlideMaster.CustomLayouts(7) 'PowerPointteki 7. tasarım boş tasarımdır. For Each Sayfa In ThisWorkbook.Worksheets If Sayfa.Index > 2 Then '2. sayfadan sonraki sayfaları sunuma eklemek için Set KopyalanacakAlan = Sayfa.UsedRange 'her sayfadaki usedrange sunuma aktarılacak Set PPslayt = PPsunum.Slides.AddSlide(i + 1, PPtasarim) DoEvents KopyalanacakAlan.CopyPicture xlScreen, xlPicture PPslayt.Shapes.Paste DoEvents Set PPsekil = PPslayt.Shapes(1) With PPsekil .LockAspectRatio = msoTrue .Left = 40 .Top = 40 .Width = 850 End With i = i + 1 End If Next Sayfa Application.ScreenUpdating = True MsgBox "Slaytlarınız oluşturuldu" PPuygulama.Visible = True Set PPuygulama = Nothing End Sub