Copier un graphique Excel sur PPT en l'incorporant

Zed -  
 Zed -
Bonjour à tous,

Afin d'automatiser des powerpoint, je cherche à copier des graphiques Excel dans un powerpoint.
Jusqu'à présent, je copiais manuellement mon graphe avec une liaison et au moment de l'édition du ppt, je cassait la liaison. Le graphique se copie alors automatiquement en image.
Ma problématique est d'avoir un graphique incorporé dans le PPT, et qui reste donc modifiable sans être lié au fichier Excel d'origine.

J'ai trouvé ce code qui fait le copier/coller, mais qui garde la liaison avec le fichier Excel.
Savez-vous comment incorporer le graphique dans le PPT pour casser cette liaison tout en gardant le graphique modifiable ?


'Allez dans Outils-Références-Cochez Microsoft PowerPoint 11.0 Object Library
Option Explicit
Sub Inserer_graph()
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Cs1 As ColorScheme
Dim NbShpe As Integer

Dim PptApp As Variant
Set PptApp = CreateObject("Powerpoint.Application")
Set PptDoc = PptApp.Presentations.Add

With PptDoc
'--- Ajoute un nouveau slide
Set Diapo = .Slides.Add(Index:=1, Layout:=ppLayoutBlank)

'copie le 1er graphique contenu dans la feuille Excel active
ActiveSheet.ChartObjects(1).Copy
'collage dans la 1ère diapositive
Diapo.Shapes.Paste

'Compte le nombre de shapes dans la diapositive:
'le dernier objet inséré correspond à l'index le plus élevé
NbShpe = Diapo.Shapes.Count

'Renomme et met en forme l'objet collé
With Diapo.Shapes(NbShpe)
.Name = "monGraph" 'personnalise le nom
.Left = 150 'définit la position horizontale dans le slide
.Top = 100 'définit la position verticale dans le slide
.Height = 300 'hauteur
.Width = 400 'largeur
End With

End With

'Sauvegarde la présentation
'dans le meme répertoire que le classeur excel contenant la macro.
PptDoc.SaveAs FileName:=ThisWorkbook.Path & "\" & "NouvellePresentation_graph.ppt" 'enregistrer avec le classeur Excel, à modifier le chemin si besoin
'ferme la presentation
PptDoc.Close
'ferme powerpoint
PptApp.Quit

MsgBox "Opération terminée."

End Sub




Configuration: Windows / Chrome 99.0.4844.84
A voir également:

1 réponse

Zed
 
up
0