Discussion :

[boubou_s]

Bonjour,

J'ai récupéré le code ci-dessous sur ce forum, mais il bug lorsque je veux insérer une slide dans la présentation powerpoint.
Par contre quand je mets ppt.visible = msoTrue, j'arrive à insérer la slide.
C'est embêtant pour moi car le client ne veut pas voir la présentatoin powerpoint entrain de se créer.
Avez-vous un autre moyen pour insérer une slide sans mettre visible = msoTrue ?
Merci d'avance.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Sub NouvellePresentation()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Cs1 As ColorScheme
Dim NbShpe As Integer
 
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

[boubou_s]

J'ai oublié une précision, je génère le powerpoint à partir d'une application ACCESS 2003 qui exporte des tableau Excel (en collage spécial image) dans powerpoint.

[Abdou_moujar]

Salut
J'ai repris ton code mais au lieu d'utiliser une liaison tardive à l'application PowerPoint via la methode CreateObject j'ai utilisé une liaison précoce en ajoutant une référence à la version de l'application installée sur ma machine (Pour moi c'est Microsoft PowerPoint 11.0 Object Library)et ce via la commande "References" du menu "Outils" de l'interface VBA d'Excel(tu pourrais faire la même chose à partir d'Access).Voici le code que j'ai utilisé.(Tu remarqueras que je n'ai pas rendu l'application visible et l'objet Chart a été bien copié)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
 
Sub CopyChartObject()
Dim wks As Worksheet
Dim shapeObj As Shape
Dim pptApp As PowerPoint.Application
Dim presObj As PowerPoint.Presentation
Dim slideObj As PowerPoint.Slide
Set wks = ActiveWorkbook.Worksheets("test")
On Error GoTo Err_Handler
Set pptApp = New PowerPoint.Application
Set presObj = pptApp.Presentations.Add
Set slideObj = presObj.Slides.Add(1, ppLayoutBlank)
For Each shapeObj In wks.Shapes
If shapeObj.Type = msoChart Then
shapeObj.Select
Selection.Copy
With slideObj.Shapes.PasteSpecial(ppPasteShape)
.Left = 100
.Top = 100
.Height = 300
.Width = 400
End With
End If
Next shapeObj
presObj.SaveAs "D:\test.ppt", ppSaveAsPresentation
pptApp.Quit
Set pptApp = Nothing
Exit Sub
Err_Handler:
If Err.Number <> 0 Then
MsgBox "Error : " & Err.Number & vbCrLf & "Source : " & Err.Source & vbCrLf & "Description : " & Err.Description
End If
Err.Clear
End Sub

Préviens moi si ça marche ou non
A+