Kontrollere PowerPoint fra Excel

Eksempelmakroen nedenfor viser hvordan man kan lage en ny PowerPoint presentasjon.

NB Les og rediger kildekoden før du kjører den i ditt eget prosjekt!
Sub CreateNewPowerPointPresentation()
' lim denne kildekoden inn i en Excel modul
' legg til en referanse til PowerPoint objektbiblioteket
' lag en ny mappe som heter C:\Foldername eller rediger filnavnene i koden
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim i As Integer, strString As String
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Add(msoTrue) ' lag en ny presentasjon
    ' eller åpne en eksisterende presentasjon
    ' Set pptPres = pptApp.Presentations.Open("C:\Foldername\Filename.ppt")
    
    ' bruk en lysbildemal
    pptPres.ApplyTemplate "C:\Program Files\Office XP\Templates\Presentation Designs\Globe.pot"
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' legg til et lysbilde
    End With
    With pptSlide ' legg til innhold
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' lysbildetittelen
        For i = 1 To 5 ' lag lysbildetekst
            strString = strString & "Linje nummer " & i & Chr(13)
        Next i
        strString = Left$(strString, Len(strString) - 1)
        .Shapes(2).TextFrame.TextRange.Text = strString ' legg til tekst
    End With
    
    ThisWorkbook.Worksheets(1).Range("A3:D10").Copy ' kopier celler fra Excel
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' legg til et lysbilde
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' lysbildetittelen
        .Shapes(2).Delete ' fjern tekstboksen
        .Shapes.Paste
        With .Shapes(.Shapes.Count)
            .Left = 50
            .Top = 100
            .Width = 600
            .Height = 400
        End With
    End With
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' legg til et lysbilde
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' lysbildetittelen
        .Shapes(2).Delete ' fjern tekstboksen
        .Shapes.PasteSpecial ppPasteBitmap
        With .Shapes(.Shapes.Count)
            .Left = 50
            .Top = 150
            .Width = 600
            '.Height = 250
        End With
    End With
    
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutText) ' legg til et lysbilde
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' lysbildetittelen
        .Shapes(2).Delete ' fjern tekstboksen
        .Shapes.PasteSpecial ppPasteOLEObject
        With .Shapes(.Shapes.Count)
            .Left = 50
            .Top = 150
            .Width = 600
            '.Height = 250
        End With
    End With
    
    ThisWorkbook.Worksheets(1).ChartObjects(1).Copy ' kopier et Excel innebygget diagram
    With pptPres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly) ' legg til et lysbilde
    End With
    With pptSlide
        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' lysbildetittelen
        .Shapes.PasteSpecial ppPasteDefault
        With .Shapes(.Shapes.Count)
            .Left = 120
            .Top = 125.125
            .Width = 480
            .Height = 289.625
        End With
    End With
    
'    ThisWorkbook.Charts(1).ChartArea.Copy ' kopier et Excel diagram
'    With pptPres.Slides
'        Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly) ' legg til et lysbilde
'    End With
'    With pptSlide
'        .Shapes(1).TextFrame.TextRange.Text = "Slide Title" ' lysbildetittelen
'        .Shapes.PasteSpecial ppPasteDefault
'        With .Shapes(.Shapes.Count)
'            .Left = 120
'            .Top = 125.125
'            .Width = 480
'            .Height = 289.625
'        End With
'    End With

    Application.CutCopyMode = False ' end cut/copy from Excel
    Set pptSlide = Nothing
    
    On Error Resume Next ' ignorer feil
    Kill "C:\Foldername\MyNewPresentation.ppt"
    With pptPres
        .SaveAs "C:\Foldername\MyNewPresentation.ppt"
        '.Close ' lukk presentasjonen
    End With
    On Error GoTo 0 ' gjenoppta normal feilbehandling
    Set pptPres = Nothing
    
    pptApp.Visible = True ' vis programmet
    'pptApp.Quit ' eller lukk PowerPoint
    Set pptApp = Nothing
End Sub
Dokumentet er sist oppdatert 2005-07-25 09:45:01 Utskriftsvennlig versjon