Problème présentation Powerpoint à partir de VBA Excel

Bonjour,

Si je viens ici aujourd'hui c'est qu'après avoir longuement testé des solutions sans succès, je commence à être à cours.
Mon problème est le suivant.
A travers un document Excel et le VBA, je récupère des données dans une base de données de manière hebdomadaire.
Puis je mets en forme automatiquement en les ajoutant dans un historique, et depuis cet historique je réalise des traitements sur mes documents.
Jusque là aucun soucis tout est fonctionnel.
Suite à cela, une fois la mise à jour effectuée, un userform s'ouvre alors demandant qu'elles sont les rapports ( que sont les présentations Powerpoint ) que l'on souhaite générer et il est possible de choisir avec des combo box plusieurs rapports ( de 1 à 16 ).
Le problème est que quand je souhaite en faire plusieurs, mon code se met à planter au milieu sans raison en me montrant une ligne de code qu'il n'aurait pas comprise et qui est souvent différente d'une fois à l'autre. Sauf qu'en appuyant sur F8, le code repart.
Impossible de savoir à quoi est du ce problème.
J'ai essayé de vider le cache après chaque présentation générée mais sans succès ( voir code ci-dessous).
Je me demande donc si quelque chose est mal fait dans mon code et si vous pourriez m'aider.

Les sources sont ci-dessous.
En vous remerciant.

Code:

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
64
65
66
67
68
69
70
71
72
73
 
Private Sub CocherButton_Click()
    CheckBox2.Value = True
    CheckBox3.Value = True
    CheckBox4.Value = True
    CheckBox5.Value = True
    CheckBox6.Value = True
    CheckBox7.Value = True
    CheckBox8.Value = True
    CheckBox9.Value = True
    CheckBox10.Value = True
    CheckBox11.Value = True
    CheckBox12.Value = True
    CheckBox13.Value = True
    CheckBox14.Value = True
    CheckBox15.Value = True
    CheckBox16.Value = True
    CheckBox17.Value = True
End Sub
 
Private Sub DécocherButton_Click()
    CheckBox2.Value = False
    CheckBox3.Value = False
    CheckBox4.Value = False
    CheckBox5.Value = False
    CheckBox6.Value = False
    CheckBox7.Value = False
    CheckBox8.Value = False
    CheckBox9.Value = False
    CheckBox10.Value = False
    CheckBox11.Value = False
    CheckBox12.Value = False
    CheckBox13.Value = False
    CheckBox14.Value = False
    CheckBox15.Value = False
    CheckBox16.Value = False
    CheckBox17.Value = False
End Sub
 
Private Sub ValiderButton_Click()
    semaine_TDB = Sheets("PRESENTATION").Cells(33, 8)
    If CheckBox2.Value = True Then
        chemin = ActiveWorkbook.Path & "\1\Pres_1_sem_" & semaine_TDB & ".ppt"
        If Dir(chemin) = "" Then
            Rapport = presentation_pdf("1", semaine_TDB)
        Else
            MsgBox "Le rapport pour 1 existe déjà !"
        End If
    End If
 
    If CheckBox3.Value = True Then
        chemin = ActiveWorkbook.Path & "\2\Pres_2_sem_" & semaine_TDB & ".ppt"
        If Dir(chemin) = "" Then
            Rapport = presentation_pdf("2", semaine_TDB)
        Else
            MsgBox "Le rapport pour 2 existe déjà !"
        End If
    End If
 
    If CheckBox4.Value = True Then
        chemin = ActiveWorkbook.Path & "\3\Pres_3_sem_" & semaine_TDB & ".ppt"
        If Dir(chemin) = "" Then
            Rapport = presentation_pdf("2", semaine_TDB)
        Else
            MsgBox "Le rapport pour 3 existe déjà !"
        End If
    End If
 
    ...
    ...
    ...
 
End Sub

J'ai mis juste un bout car c'est sensiblement la même chose partout, je ramène des cellules, des graphiques, j'ajoute du texte, des lignes,...

Code:

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
 
Function presentation_pdf(nom_rapport, semaine)
    Dim PPTApp As PowerPoint.Application
    Dim PPTDoc As PowerPoint.presentation
    Dim Sh As PowerPoint.Shape
    Dim oDataObject As DataObject
    Dim Diapo As PowerPoint.Slide
    Dim NbShpe As Integer
 
    'Permet de créer un powerpoint
    Set PPTApp = CreateObject("Powerpoint.Application")
    Set PPTDoc = PPTApp.Presentations.Add
    Sheets(nom_rapport).Select
 
    With PPTDoc
 
    ...
    ...
    ...
 
'--- Ajoute un nouveau slide et le positionne en 3eme position
        Set Diapo = .Slides.Add(Index:=3, Layout:=ppLayoutBlank)
 
        .Slides(3).Select
 
        'Crée une zone de texte pour "Contacts"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=221, Top:=0, Width:=304, Height:=39)
        With Sh.TextFrame.TextRange
            .Text = "Contacts"
            .Font.Color = RGB(31, 73, 125)
            .Font.Bold = msoTrue
            .Font.Size = 26
        End With
 
        'Crée une zone de texte pour "Activité hebdo"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=89, Top:=59, Width:=8169, Height:=29)
        With Sh.TextFrame.TextRange
            .Text = "Activité hebdo"
            .Font.Color = RGB(31, 73, 125)
            .Font.Underline = msoTrue
            .Font.Size = 18
        End With
 
        'Crée une zone de texte pour "Tendances"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=133, Top:=400, Width:=92, Height:=29)
        With Sh.TextFrame.TextRange
            .Text = "Tendances"
            .Font.Color = RGB(31, 73, 125)
            .Font.Underline = msoTrue
            .Font.Size = 18
        End With
 
        'Crée une zone de texte pour "% Contacts"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=400, Top:=400, Width:=92, Height:=29)
        With Sh.TextFrame.TextRange
            .Text = " % Contacts"
            .Font.Color = RGB(31, 73, 125)
            .Font.Underline = msoTrue
            .Font.Size = 18
        End With
 
 
        'Crée une zone de texte pour "Structure de notre activité"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=390, Top:=59, Width:=252, Height:=29)
        With Sh.TextFrame.TextRange
            .Text = "Structure de notre activité"
            .Font.Color = RGB(31, 73, 125)
            .Font.Underline = msoTrue
            .Font.Size = 18
        End With
 
'        'Crée une zone de texte pour commentaire
'        Set Sh = .Slides(3).Shapes.AddTextbox(msoTextOrientationHorizontal, _
'            Left:=30, Top:=430, Width:=333, Height:=95)
'        With Sh.Fill
'            .Visible = msoTrue
'            .ForeColor.ObjectThemeColor = msoThemeColorAccent1
'        End With
 
        'Crée une zone de texte pour "Les valeurs dans le radar sont plafonnées à 130%"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=444, Top:=380, Width:=157, Height:=16)
        With Sh.TextFrame.TextRange
            .Text = "Les valeurs dans le radar sont plafonnées à 130%"
            .Font.Color = RGB(31, 73, 125)
            .Font.Bold = msoTrue
            .Font.Size = 7
        End With
 
        'Crée une zone de texte pour "* En pourcentage"
        Set Sh = .Slides(3).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
            Left:=146, Top:=500, Width:=65, Height:=16)
        With Sh.TextFrame.TextRange
            .Text = "* En pourcentage"
            .Font.Color = RGB(31, 73, 125)
            .Font.Bold = msoTrue
            .Font.Size = 7
        End With
 
        'Copie le graphique nommé "Graphique_Contact_" & nom_rapport dans la feuille
        Sheets(nom_rapport).ChartObjects("Graphique_Contact_" & nom_rapport).Activate
        Sheets(nom_rapport).ChartObjects("Graphique_Contact_" & nom_rapport).Copy
        'On le colle dans la 2eme diapositive
        Diapo.Shapes.Paste
 
        NbShpe = Diapo.Shapes.Count
 
        'Renomme et met en forme l'objet collé
        With Diapo.Shapes(NbShpe)
            .Name = "Graphique_Contact" 'personnalise le nom
            .Left = 20 'définit la position horizontale dans le slide
            .Top = 87 'définit la position verticale dans le slide
            .Height = 179 'hauteur
            .Width = 319 'largeur
        End With
 
        'Ajoute le tableau de tendances dans la feuille
        Sheets(nom_rapport).Range("L3:M6").Copy
        Diapo.Shapes.PasteSpecial ppPasteEnhancedMetafile
 
        NbShpe = Diapo.Shapes.Count
 
        'Renomme et met en forme l'objet collé
        With Diapo.Shapes(NbShpe)
            .Name = "Tab_Contact" 'personnalise le nom
            .Left = 59 'définit la position horizontale dans le slide
            .Top = 429 'définit la position verticale dans le slide
            .Height = 77 'hauteur
            .Width = 242 'largeur
        End With
 
        'Ajoute le tableau de contact avec motifs dans la feuille
        Sheets(nom_rapport).Range("p17:Q19").Copy
        Diapo.Shapes.PasteSpecial ppPasteEnhancedMetafile
 
        NbShpe = Diapo.Shapes.Count
 
        'Renomme et met en forme l'objet collé
        With Diapo.Shapes(NbShpe)
            .Name = "Tab_Contact" 'personnalise le nom
            .Left = 400 'définit la position horizontale dans le slide
            .Top = 429 'définit la position verticale dans le slide
            .Height = 77 'hauteur
            .Width = 242 'largeur
        End With
 
        'Copie le graphique nommé "Radar_Contact" dans la feuille
        Sheets(nom_rapport).ChartObjects("Radar_Contact").Activate
        Sheets(nom_rapport).ChartObjects("Radar_Contact").Copy
        'On le colle dans la 2eme diapositive
        Diapo.Shapes.PasteSpecial
 
        NbShpe = Diapo.Shapes.Count
 
        'Renomme et met en forme l'objet collé
        With Diapo.Shapes(NbShpe)
            .Name = "Graphique_Radar_Contact" 'personnalise le nom
            .Left = 322 'définit la position horizontale dans le slide
            .Top = 100 'définit la position verticale dans le slide
            .Height = 282 'hauteur
            .Width = 391 'largeur
        End With
 
        'Permet de tracer la 1ère ligne sous le titre
        .Slides(3).Shapes.AddConnector(Type:=msoConnectorStraight, _
            BeginX:=0, BeginY:=38, EndX:=710, EndY:=38).Select
 
        'Permet de tracer la 2ème ligne sous le titre
        .Slides(3).Shapes.AddConnector(Type:=msoConnectorStraight, _
            BeginX:=0, BeginY:=43, EndX:=710, EndY:=43).Select
 
    'Sauvegarde la présentation
    'dans le meme répertoire que le classeur excel contenant la macro.
    If Dir(ActiveWorkbook.Path & "\" & nom_rapport, vbDirectory) = "" Then
        MkDir (ActiveWorkbook.Path & "\" & nom_rapport)
    End If
    PPTDoc.SaveAs Filename:=ActiveWorkbook.Path & "\" & nom_rapport & "\Pres_" & nom_rapport & "_sem_" & semaine & ".ppt"
    'ferme la presentation
    PPTDoc.Close
 
    Set oDataObject = New DataObject
    oDataObject.SetText ""
    oDataObject.PutInClipboard
 
    Set oDataObject = Nothing
 
    'Si on est sur le dernier rapport
    If nom_rapport = "12" Then
    'ferme powerpoint
        PPTApp.Quit
    End If
End Function

Bonjour,

quel est le message d'erreur ? Est-ce que ça parle d'automation ou d'échec "client" ?

malgré le fait que ce ne soit jamais la même ligne qui plante, n'y aurait-il pas néanmoins un périmètre bien défini ? Dans une procédure bien identifiée ? Et plus précisément sur un bloc de lignes de codes qui font un certain groupe d'actions ?

Citation:

Envoyé par Thresh

Le problème est que quand je souhaite en faire plusieurs, mon code se met à planter au milieu sans raison en me montrant une ligne de code qu'il n'aurait pas comprise et qui est souvent différente d'une fois à l'autre. Sauf qu'en appuyant sur F8, le code repart.
Impossible de savoir à quoi est du ce problème.

Bonjour, j'avais eu un souci similaire sur une macro qui envoyait une brouette de mails, on m'avait conseillé de rajouter un DoEvents() en fin de boucle, et ça avait bien marché.

Bonjour,

Merci pour vos réponses.

Pour l'erreur c'est toujours la même mais à des endroits différents la voici :

Erreur d'éxecution '-2147188160 (80048240)':

Shapes (unknown member) : Invalid request. Clipboard is empty or contains data which may not be pasted here.

C'est souvent sur un Diapo.Shapes.Paste

A tester halaster je regarde en début d'après midi et je te redis ça merci à toi.

Encore merci de vos réponses.

Au lieu d'un .Copy, essaye avec .CopyPicture ?

Il sera peut-être nécessaire de faire un PasteSpecial au lieu d'un Paste basique ... je te laisse faire des tests ;)

Citation:

Envoyé par halaster08

Bonjour, j'avais eu un souci similaire sur une macro qui envoyait une brouette de mails, on m'avait conseillé de rajouter un DoEvents() en fin de boucle, et ça avait bien marché.

Rebonjour,

Désolé pas eu le temps de tester plus tôt.
Mon soucis semble résolu suite à l'ajout du DoEvents() en fin de code.
Je ne sais pas exactement à quoi il sert mais pour le moment 2 générations de mes 16 présentations ce sont passés sans problème.
J'espère que ça durera.
Merci également à joe.levrai je n'ai pas pu tester ta méthode du coup vu que ça marchait je n'ai plus vraiment osé touché mais merci à toi pour ta réponse et si ça revient à planter je n'hésiterai pas à étudier ce que tu me proposais.
Je laisse le sujet ouvert jusque demain dés fois que la nouvelle génération qui m'attend demain ne fonctionne pas ^^

Bonne soirée à vous et encore merci.