CRÉER UNE PRÉSENTATION POWERPOINT DEPUIS UN CLASSEUR EXCEL

Commentaire de Le Pivert le 28/11/2008 15:51:28

Bonjour, cela arrive un peu tard, mais mieux vaut tard que jamais.
Mettez ce qui suit dans un module.
'Allez dans Outils-References et cochez: Microsoft PowerPoint 11.0 Object Library
'Remplissez la cellule A1 et ajoutez un graphique dans la feuille1
'Ensuite vous appelez "NouvellePresentation"
Sub NouvellePresentation()

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 Slide
.Slides.Add Index:=1, Layout:=ppLayoutBlank
'Crée une zone de texte (AddLabel)
Set Sh = .Slides(1).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
Left:=100, Top:=100, Width:=150, Height:=60)
'insère la valeur de la Cellule A1 dans une zone de texte
Sh.TextFrame.TextRange.Text = Range("A1")
'Modifie la couleur du texte
Sh.TextFrame.TextRange.Font.Color = RGB(255, 100, 255)


'--- Ajoute un nouveau slide et le positionner en 2eme position
Set Diapo = .Slides.Add(Index:=2, Layout:=ppLayoutBlank)

'copie le 1er graphique contenu dans la feuille Excel active
ActiveSheet.ChartObjects(1).Copy
'collage dans la 2eme 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


'--- Modifie la couleur de fond dans les différents Slides
Set Cs1 = .ColorSchemes(3)
Cs1.Colors(ppBackground).RGB = RGB(225, 233, 200)
.SlideMaster.ColorScheme = Cs1
End With

'Sauvegarde la présentation
'dans le meme répertoire que le classeur excel contenant la macro.
PptDoc.SaveAs FileName:=ThisWorkbook.Path & "\" & "NouvellePresentation.ppt"
'ferme la presentation
PptDoc.Close
'ferme powerpoint
PptApp.Quit

MsgBox "Opération terminée."
End Sub