• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Achtergrond aanpassen bij powerpoint vanuit excel mbv VBA

Status
Niet open voor verdere reacties.
R

Ralbers

Gebruiker
Lid geworden
8 jul 2011
Berichten
190
Hallo allemaal,

Ik heb een excel bestand van waaruit iedere maand automatisch een powerpoint presentatie aan wordt gemaakt.
Dit werkt als een trein.
Ik zou alleen ook graag de achtergrond automatisch aan willen passen. Het liefst met een kleurovergang.

Ik kan alleen nergens een stukje code vinden waar dat mee kan.

Mijn code is als volgt:
Code: 
Sub PowerPoint_1()

If MsgBox("Hiermee worden de sheets geexporteerd naar PowerPoint. Dit kan even duren." & vbNewLine & "Wil je doorgaan?", vbYesNo, "Doorgaan?") = vbNo Then
Exit Sub
Else
End If

'Add a reference to the Microsoft PowerPoint Library by:
    '1. Go to Tools in the VBA menu
    '2. Click on Reference
    '3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
    
    'Declareren van objecten
        Dim newPowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim cht As Excel.ChartObject
    
     'objecten starten
        On Error Resume Next
        Set newPowerPoint = GetObject(, "PowerPoint.Application")
        On Error GoTo 0
    'Openen van powerpoint applicatie
        If newPowerPoint Is Nothing Then
            Set newPowerPoint = New PowerPoint.Application
        End If
    'Nieuwe presentatie starten
        newPowerPoint.Presentations.Add
    'Powerpoint laten zien
        newPowerPoint.Visible = True
    
    For a = 1 To 100 Step 1
    'On Error GoTo opnieuw
        If Cells(a, 54).Value = "-" Then
            'Nieuwe sheet toevoegen
                newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
                newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
                Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

            'selecteren van de bron in excel
                b = Cells(a, 53).Value
                Range(b).Copy
                activeSlide.Select
                activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

                With newPowerPoint.ActiveWindow.Selection.ShapeRange
                    .Left = 15
                    .Top = 15
                    .LockAspectRatio = msoCTrue
                    .Width = 700
                End With
                'newPowerPoint.ActiveWindow.Selection.ShapeRange.PictureFormat.TransparentBackground = msoTrue
                newPowerPoint.ActiveWindow.Selection.ShapeRange.PictureFormat.TransparencyColor = RGB(255, 255, 255)
                'newPowerPoint.ActiveWindow.Selection.PictureFormat.TransparencyColor = RGB(255, 255, 255)
                Application.CutCopyMode = False
            'positie van de afbeelding in de sheet aanpassen
                'newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
                'newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 15
                
                'newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoCTrue
                'newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 700

                'newPowerPoint.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
                'newPowerPoint.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        Else
        End If
    Next a

newPowerPoint.ActivePresentation.Slides(1).Select

Range("a1").Select
MsgBox "volledig uitgevoerd"

End Sub

Heeft iemand enig idee of dit mogelijk is?

Alvast bedankt

Groeten Roel
 
Maar wat zoek je dan precies? Kan het? vast wel, maar zonder meer informatie is het moeilijk om verder te helpen
 
Je kunt als je een powerpoint presentatie hebt de achtergrond van een of alle sheets aanpassen in een bepaalde kleur.

Dat wil ik aan deze sheet toevoegen. Op een gegeven moment staat er de code om een nieuwe sheet aan te passen.
Daar zou eigenlijk bij moeten komen dat de achtergrond aangepast moet worden.

Dus niks anders dan dit:
http://office.microsoft.com/nl-nl/powerpoint-help/een-achtergrondkleur-opvulpatroon-of-achtergrondafbeelding-toevoegen-aan-of-wijzigen-in-dia-s-HP005194781.aspx

Maar dan met vba vanuit excel
 
Ik zou zeggen: doe er eens een voorbeeldje bij, of wil je dat we zelf eerst gegevens gaan inkloppen? Want dan heb ik nog wel een typcursus voor je :)
 
Ik dacht dat een voorbeeld bestand het niet veel duidelijker maakte. Maar als dat helpt. Bij deze

Excelbestand
Bekijk bijlage 20141222 Voorbeeld excel naar powerpoint.xlsm

Powerpoint (ik kon geen .pptx uploaden dus vandaar met een screenshot.
20141222 Voorbeeld.jpg

Hopelijk is dit makkelijker

Waar ik zelf niet voor mekaar krijg is een extra regel code die de achtergrond kan aanpassen zoals in het voorbeeld.

Alvast bedankt
 
Na
Code: 
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
Invoegen
Code: 
activeSlide.FollowMasterBackground = False
activeSlide.Background.Fill.PresetGradient msoGradientHorizontal, 1, msoGradientParchment
 
Het werkt.

Nog niet helemaal precies zoals ik het zou willen maar nu heb ik tenminste iets wat ik kan google.

Bedankt.
 
Voor degene die dit misschien interessant vinden.

Dit is hem geworden:
Code: 
Sub PowerPoint_1()

If MsgBox("Hiermee worden de sheets geexporteerd naar PowerPoint. Dit kan even duren." & vbNewLine & "Wil je doorgaan?", vbYesNo, "Doorgaan?") = vbNo Then
Exit Sub
Else
End If

'Add a reference to the Microsoft PowerPoint Library by:
    '1. Go to Tools in the VBA menu
    '2. Click on Reference
    '3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
    
    'Declareren van objecten
        Dim newPowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim cht As Excel.ChartObject
    
     'objecten starten
        On Error Resume Next
        Set newPowerPoint = GetObject(, "PowerPoint.Application")
        On Error GoTo 0
    'Openen van powerpoint applicatie
        If newPowerPoint Is Nothing Then
            Set newPowerPoint = New PowerPoint.Application
        End If
    'Nieuwe presentatie starten
        newPowerPoint.Presentations.Add
    'Powerpoint laten zien
        newPowerPoint.Visible = True
    
    For a = 1 To 100 Step 1
    'On Error GoTo opnieuw
        If Cells(a, 54).Value = "-" Then
            'Nieuwe sheet toevoegen
                newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
                newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
                Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

            'selecteren van de bron in excel
                b = Cells(a, 53).Value
                Range(b).Copy
                activeSlide.Select
                activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
            'achtergrond bepalen
                activeSlide.FollowMasterBackground = False
                c = c + 1
                If c = 1 Then
                    With activeSlide.Background.Fill
                        .PresetGradient msoGradientHorizontal, 1, msoGradientEarlySunset
                        .GradientAngle = 270
                        .GradientStops(1).Color.RGB = RGB(49, 133, 156)
                        .GradientStops(1).Transparency = 0.4
                        .GradientStops(2).Color.RGB = RGB(113, 161, 220)
                        .GradientStops(2).Transparency = 0.3
                        .GradientStops(3).Color.RGB = RGB(198, 217, 241)
                        .GradientStops(3).Transparency = 0
                        .GradientStops(4).Color.RGB = RGB(255, 255, 255)
                        .GradientStops(4).Transparency = 0
                        .GradientStops(5).Color.RGB = RGB(198, 217, 241)
                        .GradientStops(5).Transparency = 0.8
                    End With
                Else
                    With activeSlide.Background.Fill
                        .PresetGradient msoGradientHorizontal, 1, msoGradientEarlySunset
                        .GradientAngle = 270
                        .GradientStops(1).Color.RGB = RGB(183, 222, 232)
                        .GradientStops(1).Transparency = 0.4
                        .GradientStops(2).Color.RGB = RGB(194, 209, 237)
                        .GradientStops(2).Transparency = 0.3
                        .GradientStops(3).Color.RGB = RGB(198, 217, 241)
                        .GradientStops(3).Transparency = 0
                        .GradientStops(4).Color.RGB = RGB(255, 255, 255)
                        .GradientStops(4).Transparency = 0
                        .GradientStops(5).Color.RGB = RGB(225, 232, 245)
                        .GradientStops(5).Transparency = 0.8
                    End With
                End If
                
                With newPowerPoint.ActiveWindow.Selection.ShapeRange
                    .Left = 15
                    .Top = 15
                    .LockAspectRatio = msoCTrue
                    .Width = 700
                End With
            'achtergrond afbeelding weghalen
                newPowerPoint.ActiveWindow.Selection.ShapeRange.PictureFormat.TransparencyColor = RGB(255, 255, 255)
                Application.CutCopyMode = False
        Else
        End If
    Next a

newPowerPoint.ActivePresentation.Slides(1).Select



Range("a1").Select
'MsgBox "volledig uitgevoerd"

End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan