XL 2013 VBA (XL vers PPT) : copier un slide d'un ppt vers un autre et conserver la mise en forme

[dionys0s]

Bonjour le forum,

je m'arrache la tête sur ce sujet depuis un moment, et je n'y arrive pas.
Je dois copier un certain nombre de slides d'une présentation source vers une nouvelle présentation (vierge et inexistante au début).
Donc j'ouvre ma présentation source, je crée ma présentation cible, et pour chaque slide de la présentation source "éligible", je la copie vers la présentation cible.
J'arrive bien à les copier / coller dans la présentation cible, mais impossible de faire en sorte que la mise en forme source de la slide source soit conservée.
Le collage spécial "manuel" dans powerpoint fait très bien le taf, mais impossible de trouver comment faire ça avec du VBA (exécuté depuis Excel).

Si quelqu'un a déjà été confronté à ça je suis preneur...

D'avance, merci !

 

[dionys0s]

Re le forum,

j'arrive pas à croire que j'ai passé plus d'une demie-journée pour un truc qui se fait en deux clics manuellement...

J'ai fini par trouver du code qui fait le job. Je trouve ça ubuesque de pas pouvoir obtenir le même résultat plus simplement... Tant pis.

Si quelqu'un trouve une solution plus élégante je serai probablement extatique.

Bonne soirée à tous !

Private Sub CopySlideFormats(ByRef SourceSlide As PowerPoint.Slide, ByRef TargetSlide As PowerPoint.Slide)

  With TargetSlide
    Let .Design = SourceSlide.Design
    Let .ColorScheme = SourceSlide.ColorScheme
    If SourceSlide.FollowMasterBackground = False Then
      Let .FollowMasterBackground = False
      With .Background.Fill
        Let .Visible = SourceSlide.Background.Fill.Visible
        Let .ForeColor = SourceSlide.Background.Fill.ForeColor
        Let .BackColor = SourceSlide.Background.Fill.BackColor
      End With

      Select Case SourceSlide.Background.Fill.Type
        Case Is = msoFillTextured
          Select Case SourceSlide.Background.Fill.TextureType
            Case Is = msoTexturePreset
              Call .Background.Fill.PresetTextured(SourceSlide.Background.Fill.PresetTexture)
            Case Is = msoTextureUserDefined
          End Select
        Case Is = msoFillSolid
          Let .Background.Fill.Transparency = 0#
          Call .Background.Fill.Solid
        Case Is = msoFillPicture
          With SourceSlide
            If .Shapes.Count > 0 Then .Shapes.Range.Visible = msoFalse
            Dim bMasterShapes As MsoTriState
            bMasterShapes = .DisplayMasterShapes
            .DisplayMasterShapes = msoFalse
            .Export SourceSlide.Parent.Path & .SlideID & ".png", "PNG"
          End With
          Call .Background.Fill.UserPicture(SourceSlide.Parent.Path & SourceSlide.SlideID & ".png")
          Call Kill(SourceSlide.Parent & SourceSlide.SlideID & ".png")
          With SourceSlide
            Let .DisplayMasterShapes = bMasterShapes
            If .Shapes.Count > 0 Then .Shapes.Range.Visible = msoTrue
          End With
        Case Is = msoFillPatterned
          Call .Background.Fill.Patterned(SourceSlide.Background.Fill.Pattern)
        Case Is = msoFillGradient
          Select Case SourceSlide.Background.Fill.GradientColorType
            Case Is = msoGradientTwoColors
              Call .Background.Fill.TwoColorGradient( _
                SourceSlide.Background.Fill.GradientStyle, _
                SourceSlide.Background.Fill.GradientVariant)
            Case Is = msoGradientPresetColors
              Call .Background.Fill.PresetGradient( _
                SourceSlide.Background.Fill.GradientStyle, _
                SourceSlide.Background.Fill.GradientVariant, _
                SourceSlide.Background.Fill.PresetGradientType)
            Case Is = msoGradientOneColor
                Call .Background.Fill.OneColorGradient( _
                  SourceSlide.Background.Fill.GradientStyle, _
                  SourceSlide.Background.Fill.GradientVariant, _
                  SourceSlide.Background.Fill.GradientDegree)
          End Select
        Case Is = msoFillBackground
              ' Only applicable to shapes.
      End Select
    End If
  End With

End Sub

 

[job75]

Bonsoir dionys0s,

Téléchargez les fichiers joints dans le même dossier et voyez la macro du bouton :

Sub Copier_PP()
Dim PPap As Object
On Error Resume Next
Set PPap = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If PPap Is Nothing Then Set PPap = CreateObject("PowerPoint.Application")
PPap.Visible = True
PPap.Presentations.Open(ThisWorkbook.Path & "\PP(1).pptx").Slides(3).Copy 'copie la Slide n°3 dans le presse-papiers
PPap.Presentations.Open(ThisWorkbook.Path & "\PP(2).pptx").Slides.Paste 2 'colle en 2ème position
AppActivate "PowerPoint"
End Sub

A+

 

[job75]

Bonjour dionys0s, le forum,

Après le test précédent copier toutes les Slides est évident :

Sub Copier_PP()
Dim PPap As Object, SL1 As Object, SL2 As Object, s As Object
On Error Resume Next
Set PPap = GetObject(, "PowerOoint.Application")
On Error GoTo 0
If PPap Is Nothing Then Set PPap = CreateObject("PowerPoint.Application")
Set SL1 = PPap.Presentations.Open(ThisWorkbook.Path & "\PP(1).pptx").Slides
Set SL2 = PPap.Presentations.Open(ThisWorkbook.Path & "\PP(2).pptx").Slides
For Each s In SL1
    s.Copy
    SL2.Paste SL2.Count + 1
Next
AppActivate "PowerPoint"
End Sub

On constate que les textes AAAA BBBB CCCC se centrent [EDIT] systématiquement.

A+

 

[dionys0s]

Bonjour job75

merci beaucoup pour ton temps, une fois de plus.
Effectivement, les textes sont ok, mais le résultat obtenu n'est pas le même que lorsque je fais un collage spécial en conservant la mise en forme source, et c'est ce résultat que je cherche à atteindre (et que l'horrible fonction postée plus faut permet de faire).

A+

 

[job75]

Effectivement en manuel il y a 3 options possibles dont une qui conserve la mise en forme source.

 

[dionys0s]

C'est ça. Je suis surpris qu'une fonctionnalité aussi accessible n'ait pas été implémentée en VBA.

 

[job75]

Au lieu de copier les Slides on peut bêtement copier le 1er fichier PP sur le second :

Sub Copier_PP()
Dim F1$, F2$
F1 = ThisWorkbook.Path & "\PP(1).pptx"
F2 = ThisWorkbook.Path & "\PP(2).pptx"
CreateObject("Scripting.FileSystemObject").CopyFile F1, F2
ThisWorkbook.FollowHyperlink F1
ThisWorkbook.FollowHyperlink F2
End Sub

puisque vous avez dit qu'au départ le second fichier PP est vierge...

 

[dionys0s]

Re,

c'est pas possible non plus de cette manière, mais c'est purement lié à l'objet de ma macro.
En fait le ppt source est un modèle, et en fonction d'un certain nombre de paramètres gérés dans Excel, on crée un nouveau ppt à partir du 1e. Le ppt généré contiendra certains slides du modèle, mais pas tous. Le problème, c'est que certains slides du ppt modèle peuvent être amenés à se trouver à plusieurs endroits dans le ppt générés. Donc d'une manière ou d'une autre je dois pouvoir copier coller un slide en conservant la mise en forme source. Sans cette histoire de slides en doublons à plusieurs endroits, j'aurais juste sauvegardé le modèle sous un autre nom et supprimé les slides qui n'ont rien à y faire.