Excel - Export naar PPT

Status
Niet open voor verdere reacties.

MauriceSmit

Gebruiker
Lid geworden
1 jul 2008
Berichten
168
Hoi!

Ik maak zelf veel gebruik van excel en heb ook een custom toolbar met enige additionele functionaliteiten om het werk te versoepelen; een leuke gadget is een snelle export van je huidige selectie naar powerpoint:

Code:
Public Sub SelectionToPPT()
    Dim PPApp As PowerPoint.Application
    Set PPApp = GetObject("", "PowerPoint.Application")
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim ScaleFactor As Double
    Dim SlideTitle As String
    
    SlideTitle = InputBox("Title for Slide", "Title", ActiveSheet.Name)
    
    With PPApp
        .Activate
        ' Create a new presentation
        Set PPPres = .Presentations.Add(msoTrue)
        
        ' Set up slide master for office 2003
        If Application.Version <> "12.0" Then
            PPPres.SlideMaster.Shapes("Rectangle 4").TextFrame.TextRange.Font.Size = 10
            PPPres.SlideMaster.Shapes("Rectangle 6").TextFrame.TextRange.Font.Size = 10
            PPPres.SlideMaster.Shapes("Rectangle 4").ScaleHeight 0.51, msoFalse, msoScaleFromBottomRight
            PPPres.SlideMaster.Shapes("Rectangle 6").ScaleHeight 0.51, msoFalse, msoScaleFromBottomRight
        End If
        
        ' Format the slides to have a date/time and slide number
        With PPPres.SlideMaster.HeadersFooters
            With .DateAndTime
                .Format = ppDateTimeddddMMMMddyyyy
                .Text = ""
                .UseFormat = msoTrue
                .Visible = msoTrue
            End With
            .Footer.Visible = msoFalse
            .SlideNumber.Visible = msoTrue
        End With
        
        With PPSlide
            Set PPSlide = PPPres.Slides.Add(1, ppLayoutText)
            With PPSlide
                ' Delete the text slide that is created with the ppLayoutText format
                .Shapes(2).Delete
                With .Shapes(1)
                    ' Change the height and width of the title text
                    .ScaleHeight 0.93, msoFalse, msoScaleFromTopLeft
                    .ScaleWidth 1.02, msoFalse, msoScaleFromTopLeft
                    ' Move the title text
                    .IncrementLeft -6#
                    .IncrementTop -21.62
                    ' Format the title text
                    With .TextFrame.TextRange
                        .Text = SlideTitle
                        .Paragraphs(Start:=1, Length:=1).ParagraphFormat.Alignment = ppAlignLeft
                        .Font.Size = 36
                        .Font.Color.SchemeColor = ppAccent1
                    End With
                End With
                
                ' Add a dividing line between the title and screenshot
                With .Shapes.AddLine(0#, 72#, 720#, 72#)
                    .Line.Weight = 2.25
                    .Line.Visible = msoTrue
                    .Line.Style = msoLineSingle
                    .Line.ForeColor.SchemeColor = ppAccent1
                End With
            
                Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                With .Shapes.Paste
                    .Top = 80
                    .Left = 30
                    If .Height > 430 Then
                        ScaleFactor = (430 / .Height)
                        .ScaleHeight ScaleFactor, msoFalse, msoScaleFromTopLeft
                        
                        If .Width > 665 Then
                            ScaleFactor = (665 / .Width)
                            .ScaleWidth ScaleFactor, msoFalse, msoScaleFromTopLeft
                        End If
                    Else
                        ScaleFactor = (665 / .Width)
                        .ScaleWidth ScaleFactor, msoFalse, msoScaleFromTopLeft
                        
                        If .Height > 430 Then
                            ScaleFactor = (430 / .Height)
                            .ScaleHeight ScaleFactor, msoFalse, msoScaleFromTopLeft
                        End If
                    End If
                End With
            End With
        End With
    End With
        
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End Sub

Maak eventueel een knop aan in je werkbalk om deze macro aan te hangen.
Succes!
 
Hoi Maurice,

Ik heb Microsoft Powerpoint 11.0 Object Library toegevoegd als reference en het werkt als een tierelier. Bedankt!

Guus2005:thumb:
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan