Excel sayfalarını PowerPoint'e aktarma

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

Paylaş: