Discussion :

[Marneus22]

j'ai une macro Excel qui génère une présentation PPT

celle-ci a été créée avec EXCEL 2010 et génère un POWERPOINT 2010

Sur le même fichier Excel, j'ai deux macros différentes. Lorsque j'exécute l'une des deux macros, j'ai systématiquement le message suivant :



Microsoft Powerpoint a cessé de fonctionner


Ca fonctionnait du tonnerre ce matin et après avoir rajouter des lignes de codes, ça ne fonctionne plus .


IMPORTANT : mon code n'est pas faux puisque lorsque je mets des stops dans la macro et que je l'exécute en pas à pas, tout ce passe bien

dès que je la lance en continu, cela bloque

Quelqu'un pourrait-il me venir en aide ?

[Marc-L]

Bonjour,

vu la pléthore d'informations à disposition, on peut juste conclure la cause est bien les lignes ajoutées ‼

Il suffit donc de les enlever et tout rentre dans l'ordre …

[EngueEngue]

Très perspicace... je n'aurais pas dit mieux.

Je rejoins Marc sur sa suggestion.

Edit: Tu pourrais essayer de rallumer 17 fois ta machine, ce genre d'erreurs se solutionne souvent avec 17 Reboots

[Marneus22]

Bonjour à vous 2 et merci pour vos réponses.

Bon, les lignes de codes ajoutées ne sont peuvent pas être la source de mon problème puisque pas à pas, ça fonctionne. De plus, il arrive que parfois, je ne sais par quel miracle, ça fonctionne.

Voici un peu plus d'info qui pourrait vous aider à mieux comprendre le pb.
En fait, je transfère des graphs d'un fichier excel vers powerpoint. Lorsque j'intègre (via la macro) un deuxième graph sur une slide où se trouve déjà un graph, PowerPOint cesse de fonctionner.


EngueEngue, J'en suis au 18ème reboot et ça ne fonctionne toujours pas... .
Dois-je tenter jusqu'au 20ème ?


Sinon, auriez-vous d'autres solutions ?

Cordialement

[EngueEngue]

Mais montre nous ton code qu'on puisse simuler la même connerie que tu fais...

[illight]

Bonjour,

vu la pléthore d'informations à disposition, on peut juste conclure la cause est bien les lignes ajoutées ‼

Il suffit donc de les enlever et tout rentre dans l'ordre …

Tu as essayé quand même ce qu'il a dit : enlever les lignes rajoutées, voir si ça plante quand même ?
Certes, ça fonctionne au pas à pas, et ça fonctionne une fois sur 10, mais il serait quand même bien de savoir si, en enlevant ces lignes rajoutées, ça fonctionne tout le temps ou pas => Tu auras alors une piste pour savoir d'où vient ton souci

Mais montre nous ton code qu'on puisse simuler la même connerie que tu fais...

Mouarf

[Marneus22]

Bonjour illight et merci pour ta réponse.

Avant toute chose, merci à vous tous de prendre le temps de me lire.
Etant très pressé par le temps, et très tressé par ce problème, je ne me suis pas posé tranquillement pour prendre le temps de rédiger clairement mon pb.

Alors voilà je vais essayé de me récupérer... :

J'ai un fichier excel A sur lequel j'ai deux modules :
1) Après avoir sélectionné plusieurs graphes sur plusieurs feuilles excel, la macro appel un fichier ppt et colle les graphs, les met en forme et les place sur ma feuille ppt (un graph / feuille) --> Cette macro est OK !

2) Une fois les graphs intégrés sur le ppt, on peut ajouter des tableaux (qui ne sont en fait qu'un ensemble de cells sous excel) ou des graphiques. On peut le faire soit sur les slides qui existent (donc qui ont un graphique dessus) soit sur une nouvelle slide. La macro sur le module 2 appelle un Userform (voir photo) et qui propose ces deux dernières options (1) sur une slide qui existe, 2) sur une nouvelle slide). Le problème arrive seulement sur l'option 1).

Le code que vous trouverez ci-dessous présente est divisée en plusieurs parties et sous parties (un peu comme on le ferait pour une dissertation)

I) On insert sur une slide existante : Ligne 31
a) on compte le nombre de shapes sur la slide : ligne 49
b) on compte le nombre de graphiques sur la slide : ligne 66

II) Mise en forme de la nouvelle shape : Ligne 88
a) Si c'est un tableau : ligne 91
b) si c'est un graphique : ligne 192

III) Placement des shapes (sur la slide) : Ligne 274
a) Si on a deux graphique sur la slide : Ligne 278
1. Placement + Mise en forme du graphique initialement présent (issue de la première macro) ---> C'est dans cette partie que PPT plante : Ligne 300
2. Placement du nouveau graphique ----> il est déjà arrivé que PPT bug à cette étape également. : Ligne 315

b) Si on a un graphique et un tableau sur la slide --> ici tout fonctionne : Ligne 329
1. Placement + Mise en forme du graphique initialement présent (issue de la première macro) : ligne 332
2.Placement du nouveau tableau : ligne 360

c) Si on a deux nouvelles shapes sur la slide (NbShpe = 7) ---> Ici aussi, PPT bug, seulement quand on ajoute un graphique après avoir ajouté un tableau : Ligne 378
d) j'insère une feuille en background pour rendre le tout plus esthétique ligne : Ligne 419

IV) On insère sur une nouvelle slide (Option 2 , pas de problème) : ligne 453

Pour faciliter la compréhension, avant d'ajouter une shape il y a 5 shapes sur la slides (titreS, textbox, et le fameux Graphique ajouté avec la macro 1)). Du coup, à l'étape III)c), on a 7 shapes.

Voilà le code :

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
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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
Private Sub CommandButton1_Click()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim PptLayout As CustomLayout
Dim Tbl As Table
Dim Plage As Range
Dim pn As Long
Dim sn As Long
pn = TextBox1.Value 'si on ajouter une shape sur la slide pn la shape sélectionnée
sn = TextBox2.Value 'si on ajoute sur une nouvelle slide la shape sélectionnée
n = 0
 
UserForm1.Hide
Selection.Copy
 
'On vérifie si PPT est ouvert
On Error Resume Next
Set PptApp = GetObject(, "PowerPoint.application")
If Err.Number <> 0 Then
MsgBox "Microsoft PowerPoint is not open" & Chr(13) & "Please select your graphs and hit : '1) Create PPT'" & Chr(13) & "and leave the presentation open"
Exit Sub
End If
'FIN On vérifie si PPT est ouvert
 
'''''''''''''''''''''''''''''''''''''''''''I) ON INSERT SUR UNE SLIDE EXISTANTE''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''-------------------------------------------------------------------------------------------'''''''''''''''''
 
If Not pn = "0" Then '----> Option 1 sur l'Userform (obligé de mettre "0" car si empty, message d'erreur)
 
    If Not sn = "0" Then
    MsgBox "Please Enter '0' in one of the two options"
    TextBox1.Value = "0"
    TextBox2.Value = "0"
    Exit Sub
    End If
 
PptApp.ActiveWindow.ViewType = ppViewSlide
PptApp.ActivePresentation.Slides(pn).Select
 
NbShpe = PptApp.ActivePresentation.Slides(pn).Shapes.Count '---> on compte le nombre de Shapes pour éviter les slides surchargées en info (de base il y a 5 shapes).
 
If NbShpe > 6 Then ' on check avant de coller la shape
          MsgBox "Too many figures on this slide..."
          Exit Sub
End If
 
PptApp.ActiveWindow.View.Paste '--> Si pas trop de shape on colle l'objet sélectionné d'excel sous ppt.
NbShpe = PptApp.ActivePresentation.Slides(pn).Shapes.Count '--> et on compte à nouveau le nombre de shapes pour le placement (voir partie III)
 
'----------Compte le nombre de Graphique(s) sur la slide----------------'
'-----------------------------------------------------------------------'
 
For Each Shape In PptApp.ActiveWindow.View.Slide.Shapes
    If Shape.HasChart Then
    n = n + 1
    End If
Next Shape
 
'----------Fin Compte le nombre de Graphique(s) sur la slide------------'
'-----------------------------------------------------------------------'
 
'''''''''''''''''''''''''''''''''''''''''FIN I) ON INSERT SUR UNE SLIDE EXISTANTE''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''-------------------------------------------------------------------------------------------'''''''''''''''''
 
 ''''''''''''''''''''''''''''''''''''''''''II) MISE EN FORME DE LA NOUVELLE SHAPE''''''''''''''''''''''''''''''''''''''''''''''
 
'''''''''''''''''-----------------a) SI TABLEAU (range cells sous excel)-------------'''''''''''''''''
'''''''''''''''''--------------------------------------------------------------------'''''''''''''''''
 
If Not PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe).HasChart = msoTrue Then
 
'--------------------- Mise en forme du Tableau ----------------------'
'---------------------------------------------------------------------'
 
Set Tbl = PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe).Table
nbrelignes = Tbl.Rows.Count
nbrecols = Tbl.Columns.Count
 
    If nbrecols < 3 Then
    UserForm1.Hide
    TextBox1.Value = ""
    PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe).Delete
    MsgBox "Please select a bigger table"
    PptApp.ActiveWindow.ViewType = ppViewNormal
    Exit Sub
    End If
 
    If nbrelignes < 3 Then
    UserForm1.Hide
    TextBox1.Value = ""
    PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe).Delete
    MsgBox "Please select a bigger table"
    PptApp.ActiveWindow.ViewType = ppViewNormal
    Exit Sub
    End If
 
        For i = 1 To nbrelignes
        For j = 1 To nbrecols
 
            With Tbl.Cell(i, j)
             .Shape.TextFrame.TextRange.Characters.ParagraphFormat.Alignment = ppAlignCenter
             .Shape.TextFrame.TextRange.Font.Bold = msoTrue
             .Shape.TextFrame.VerticalAnchor = msoAnchorMiddle
             .Shape.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
             If i > 2 Then
                If j > 1 Then
                End If
             End If
             If j = 1 Then
                If i < nbrelignes Then
                .Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 100, 0)
                End If
             End If
 
            End With
 
            With Tbl.Columns(j)
            .Width = (PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe - 1).Width / nbrecols)
            .Cells.Borders(ppBorderLeft).Weight = 1
            .Cells.Borders(ppBorderLeft).ForeColor.RGB = RGB(50, 50, 50)
            .Cells.Borders(ppBorderRight).Weight = 1
            .Cells.Borders(ppBorderRight).ForeColor.RGB = RGB(50, 50, 50)
            End With
 
        Next j
            With Tbl.Rows(i)
            .Height = (PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe - 1).Height / nbrelignes)
            .Cells.Borders(ppBorderTop).Weight = 1
            .Cells.Borders(ppBorderTop).ForeColor.RGB = RGB(50, 50, 50)
            .Cells.Borders(ppBorderBottom).Weight = 1
            .Cells.Borders(ppBorderBottom).ForeColor.RGB = RGB(50, 50, 50)
            End With
        Next i
 
With Tbl
 
.Cell(1, 2).Merge MergeTo:=.Cell(1, .Columns.Count)
.Cell(1, 2).Shape.TextFrame.TextRange.Text = "Assessed PL"
.Cell(1, 2).Shape.TextFrame.TextRange.Characters.ParagraphFormat.Alignment = ppAlignCenter
 
.Cell(2, 1).Merge MergeTo:=.Cell(1, 1)
.Cell(1, 1).Shape.TextFrame.TextRange.Text = "Required PL"
.Cell(1, 1).Shape.TextFrame.TextRange.Characters.ParagraphFormat.Alignment = ppAlignCenter
 
End With
 
'--------------------Fin Mise en forme du Tableau ----------------------'
'-----------------------------------------------------------------------'
 
End If
 
'''''''''''''''''--------------------- FIN a) SI TABLEAU ----------------------------'''''''''''''''''
'''''''''''''''''--------------------------------------------------------------------'''''''''''''''''
 
'''''''''''''''''--------------------------b) SI GRAPHIQUE ----------------------------'''''''''''''''''
'''''''''''''''''----------------------------------------------------------------------'''''''''''''''''
 If PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe).HasChart = msoTrue Then
 
 With PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe).Chart '----------------------------------------------------------> Mise en forme NOUVEAU graphique
 
                 .SetElement (msoElementDataLabelCenter)
                 .PlotArea.Position = xlChartElementPositionAutomatic
                 .PlotArea.Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
 
 
                 .HasAxis(xlCategory, xlValue) = True
                 .Axes(xlCategory).TickLabels.Orientation = 90
                 .Axes(xlCategory).TickLabels.Font.Color = RGB(0, 0, 0)
                 .Axes(xlCategory).TickLabelPosition = xlLow
                 .Axes(xlValue).TickLabels.Delete
                    If .SeriesCollection(1).Points.Count < 5 Then
                    .Axes(xlCategory).TickLabels.Orientation = 0
                    End If
 
                 .HasTitle = True
                 .ChartTitle.Select '-------------------------------------------> Mise en Forme Titre
                 .SetElement (msoElementChartTitleAboveChart)
                 .ChartTitle.Characters.Font.Size = 12
                 .ChartTitle.Characters.Font.Color = RGB(0, 0, 0) '------------------------> Fin Mise en Forme Titre
 
                 .Legend.Select '-----------------------------------------------> Mise en Forme Légende
                 .SetElement msoElementLegendRightOverlay
                 .Legend.Top = 32
                 .Legend.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) '-------------------------> Fin Mise en Forme Légende
 
                 .ApplyDataLabels Type:=xlDataLabelsShowValue, AutoText:=True
 
                     For Each Sc In .SeriesCollection '----------------------> Mise en forme des étiquettes de données
 
                     Sc.DataLabels.Format.TextFrame2.TextRange.Font.Bold = msoTrue
                     Sc.DataLabels.Format.TextFrame2.TextRange.Font.Size = 12
                     Sc.DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
                     Sc.DataLabels.Orientation = 45
 
                     If .SeriesCollection.Count = 3 Then
                        .SeriesCollection(1).DataLabels.Position = xlLabelPositionInsideBase
                        .SeriesCollection(3).DataLabels.Position = xlLabelPositionInsideBase
                     End If
 
                     '-----effacer les étiquettes = à 0 ------------------------'
                     q = Sc.Points.Count
                       For w = 1 To q
                         Sc.Points(w).HasDataLabel = True
                         a = Sc.Points(w).DataLabel.Text
                            If a = 0 Then
                            Sc.Points(w).DataLabel.Delete
                            End If
                       Next w
                      '-----fin de effacer les étiquettes = à 0 ------------------------'                 
 
                     Next Sc '--------------------------------------------------> fin Mise en forme étiquettes de données
 
                 End With '-------------------------------------------------------------------------------------------------> Fin Mise en forme NOUVEAU graphique
 
 End If
'''''''''''''''''--------------------- FIN b) SI GRAPHIQUE ----------------------------'''''''''''''''''
'''''''''''''''''----------------------------------------------------------------------'''''''''''''''''
 
 '''''''''''''''''''''''''''''''''''''''''' FIN II) MISE EN FORME DE LA NOUVELLE SHAPE''''''''''''''''''''''''''''''''''''''''''''''
 
 '''''''''''''''''''''''''''''''''''''''''''''''''''''III) PLACEMENT DES SHAPES'''''''''''''''''''''''''''''''''''''''''''''''''''''
 
        'a)  Si le nombre de Graphique sur la slide(pn) = 2
        If n = 2 Then
            If NbShpe = 5 Then
 
      '--------------------- Placement + Mise en forme du Graphique initialement présent ---------------------'
      '-------------------------------------------------------------------------------------------------------'
 
With PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe - 1)
    If .HasChart = True Then
    .Left = 380
    .Height = 200
    .Width = 370
    .Top = 80
    .Shadow.Size = 0
    .Line.Visible = msoFalse
    .Fill.Visible = msoFalse
 
        With .Chart
        .ChartTitle.Characters.Font.Size = 12
        .Axes(xlValue).TickLabels.Delete
            For Each Sc In .SeriesCollection
            Sc.DataLabels.Format.TextFrame2.TextRange.Font.Size = 12
            Next Sc '------------------------------------------------------------> C'est dans cette zone que PPT cesse de fontionner.
        End With
    End If
End With
      '--------------------- Fin Placement + Mise en forme du Graphique initialement présent ----------------------'
      '------------------------------------------------------------------------------------------------------------'
 
 
      '--------------------- Placement du nouveau Graphique ---------------------'
      '--------------------------------------------------------------------------'
With PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe)
    If .HasChart = True Then
    .Left = 380
    .Height = 200
    .Width = 370
    .Top = 280
    .Line.Visible = msoFalse
    End If
End With
      '-------------------- Fin Placement du nouveau Graphique ------------------'
      '--------------------------------------------------------------------------'
 
     End If
 End If    ' FIN a)  Si le nombre de Graphique sur la slide(pn) = 2
 
      'b)  Si le nombre de Graphique sur la slide(pn) = 1
      If n = 1 Then
 
      '--------------------- Placement + Mise en forme du Graphique initialement présent ---------------------'
      '-------------------------------------------------------------------------------------------------------'
With PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe - 1)
If .HasChart = True Then
    .Left = 390
    .Height = 300
    .Width = 370
    .Top = 80
    .Shadow.Size = 0
    .Line.Visible = msoFalse
    .Fill.Visible = msoFalse
 
    With .Chart
    .ChartTitle.Characters.Font.Size = 12
        For Each Sc In .SeriesCollection
        Sc.DataLabels.Format.TextFrame2.TextRange.Font.Size = 12
        Sc.DataLabels.Format.TextFrame2.TextRange.Font.Bold = msoTrue
        Sc.DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
        Next Sc    '-------------------------------> Quand j'intègre un esemble de cellules, powerpoint ne bug pas !!!!!!!!!!!!!!!!!
    End With
 
End If
 
End With
 
      '--------------------- Fin Placement + Mise en forme du Graphique initialement présent ----------------------'
      '------------------------------------------------------------------------------------------------------------'
 
      '--------------------- Placement du nouveau Tableau -----------------------'
      '--------------------------------------------------------------------------'
 
With PptApp.ActivePresentation.Slides(pn).Shapes(NbShpe)
.Left = 395
.Height = 95
.Width = 360
.Top = (75 + 400 - .Height)
End With
 
      '-------------------- Fin Placement du nouveau Tableau --------------------'
      '--------------------------------------------------------------------------'
 
End If    ' FIN b)  Si le nombre de Graphique sur la slide(pn) = 1
 
          ' c)  Si le nombre de SHAPES sur la slide(pn) = 7 (on a déjà ajouter un graph ou un tableau)
          If NbShpe = 7 Then
 
For Each Sh In PptApp.ActivePresentation.Slides(pn).Shapes '--> On vérifie si un background blanc qui a le nom "Rect" existe déjà
        If Sh.Name = "Rect" Then
        a = 10
        End If '--> FIN On vérifie si un background blanc qui a le nom "Rect" existe déjà
Next Sh
 
For i = 5 To NbShpe '-----------> Modification de la mise en forme des shapes
 
    With PptApp.ActivePresentation.Slides(pn).Shapes(i)
        If .HasChart Then
            With .Chart
                If .HasTitle Then
                .ChartTitle.Delete
                End If
                With PptApp.ActivePresentation.Slides(pn).Shapes(i)
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
                .Shadow.Size = 0
                End With
            End With
        End If
 
        If Not PptApp.ActivePresentation.Slides(pn).Shapes(i).Name = "Rect" Then
        .Left = 395
        .Height = 400 / 3
        .Width = 360
        .Top = (80 + (i - 5) * .Height)
        End If
 
    End With
Next i '-----------> FIN Modification de la mise en forme shapes
 
End If    ' FIN c)  Si le nombre de SHAPES sur la slide(pn) = 7 (on a déjà ajouter un graph ou un tableau)
 
          ' d)  Création d'une feuille blanche en background si a <> 10 (voir partie c)
 
If Not a = 10 Then
    Set Sh = PptApp.ActivePresentation.Slides(pn).Shapes.AddShape(msoShapeRectangle, 390, 78, 370, 405)
        With Sh
        .Name = "Rect"
        .Fill.Visible = msoCTrue
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Fill.Transparency = 0
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Line.Weight = 1.75
        .ZOrder msoSendToBack
        .Shadow.Visible = msoCTrue
        .Shadow.Size = 100
        .Shadow.Transparency = 0.01
        .Shadow.OffsetX = 3
        .Shadow.OffsetY = 3
        .Shadow.Blur = 5
        End With
End If
 
          ' FIN d)  Création d'une feuille blanche en background
 
      ''''''''''''''''''''''''''''''''''''''''''''''''FIN III) PLACEMENT DES SHAPES'''''''''''''''''''''''''''''''''''''''''''''''''''''
 
TextBox1.Value = "0"
End If
 
'''''''''''''''''''''''''''''''''''''''''''IV) ON INSERT SUR UNE NOUVELLE SLIDE''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''-------------------------------------------------------------------------------------------'''''''''''''''''
 
If Not sn = "0" Then '----> Option 2 sur l'Userform (obligé de mettre "0" car si empty, message d'erreur)
 
    If Not pn = "0" Then
    MsgBox "Please Enter '0' in one of the two options"
    TextBox1.Value = "0"
    TextBox2.Value = "0"
    Exit Sub
    End If
 
Set PptLayout = PptApp.ActivePresentation.Slides(2).CustomLayout
Set Diapo = PptApp.ActivePresentation.Slides.AddSlide(Index:=sn + 1, pCustomLayout:=PptLayout)
 
PptApp.ActiveWindow.ViewType = ppViewSlide
PptApp.ActivePresentation.Slides(sn + 1).Select
PptApp.ActiveWindow.View.Paste
NbShpe = PptApp.ActivePresentation.Slides(sn + 1).Shapes.Count
 
TextBox2.Value = "0"
 
'''''''''''''''''------------------------IV - a) SI TABLEAU ----------------------------'''''''''''''''''
'''''''''''''''''--------------------------------------------------------------------'''''''''''''''''
 
If Not PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe).HasChart = msoTrue Then               
 
'--------------------- Mise en forme du Tableau ----------------------'
'---------------------------------------------------------------------'
 
Set Tbl = PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe).Table
nbrelignes = Tbl.Rows.Count
nbrecols = Tbl.Columns.Count
 
    If nbrecols < 3 Then
    UserForm1.Hide
    TextBox1.Value = ""
    PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe).Delete
    MsgBox "Please select a bigger table"
    PptApp.ActiveWindow.ViewType = ppViewNormal
    Exit Sub
    End If
 
    If nbrelignes < 3 Then
    UserForm1.Hide
    TextBox1.Value = ""
    PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe).Delete
    MsgBox "Please select a bigger table"
    PptApp.ActiveWindow.ViewType = ppViewNormal
    Exit Sub
    End If
 
        For i = 1 To nbrelignes
        For j = 1 To nbrecols
 
            With Tbl.Cell(i, j)
             .Shape.TextFrame.TextRange.Characters.ParagraphFormat.Alignment = ppAlignCenter
             .Shape.TextFrame.TextRange.Font.Bold = msoTrue
             .Shape.TextFrame.VerticalAnchor = msoAnchorMiddle
             .Shape.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
             If i > 2 Then
                If j > 1 Then
                End If
             End If
             If j = 1 Then
                If i < nbrelignes Then
                .Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 100, 0)
                End If
             End If
 
            End With
 
            With Tbl.Columns(j)
            .Width = (PptApp.ActivePresentation.Slides(sn).Shapes(NbShpe - 1).Width / nbrecols)
            .Cells.Borders(ppBorderLeft).Weight = 1
            .Cells.Borders(ppBorderLeft).ForeColor.RGB = RGB(50, 50, 50)
            .Cells.Borders(ppBorderRight).Weight = 1
            .Cells.Borders(ppBorderRight).ForeColor.RGB = RGB(50, 50, 50)
            End With
 
        Next j
            With Tbl.Rows(i)
            .Height = (PptApp.ActivePresentation.Slides(sn).Shapes(NbShpe - 1).Height / nbrelignes)
            .Cells.Borders(ppBorderTop).Weight = 1
            .Cells.Borders(ppBorderTop).ForeColor.RGB = RGB(50, 50, 50)
            .Cells.Borders(ppBorderBottom).Weight = 1
            .Cells.Borders(ppBorderBottom).ForeColor.RGB = RGB(50, 50, 50)
            End With
        Next i
 
With Tbl
 
.Cell(1, 2).Merge MergeTo:=.Cell(1, .Columns.Count)
.Cell(1, 2).Shape.TextFrame.TextRange.Text = "Assessed PL"
.Cell(1, 2).Shape.TextFrame.TextRange.Characters.ParagraphFormat.Alignment = ppAlignCenter
 
.Cell(2, 1).Merge MergeTo:=.Cell(1, 1)
.Cell(1, 1).Shape.TextFrame.TextRange.Text = "Required PL"
.Cell(1, 1).Shape.TextFrame.TextRange.Characters.ParagraphFormat.Alignment = ppAlignCenter
 
End With
 
'--------------------Fin Mise en forme du Tableau ----------------------'
'-----------------------------------------------------------------------'
 
End If
 
'''''''''''''''''--------------------- FIN IV - a) SI TABLEAU ----------------------------'''''''''''''''''
'''''''''''''''''--------------------------------------------------------------------'''''''''''''''''
 
'''''''''''''''''-------------------- IV - b) SI GRAPHIQUE ----------------------------'''''''''''''''''
'''''''''''''''''----------------------------------------------------------------------'''''''''''''''''
 
If PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe).HasChart = msoTrue Then
 
 With PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe).Chart '----------------------------------------------------------> Mise en forme NOUVEAU graphique
 
                 .SetElement (msoElementDataLabelCenter)
                 .PlotArea.Position = xlChartElementPositionAutomatic
                 .PlotArea.Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
 
 
                 .HasAxis(xlCategory, xlValue) = True
                 .Axes(xlCategory).TickLabels.Orientation = 90
                 .Axes(xlCategory).TickLabels.Font.Color = RGB(0, 0, 0)
                 .Axes(xlCategory).TickLabelPosition = xlLow
                 .Axes(xlValue).TickLabels.Delete
                    If .SeriesCollection(1).Points.Count < 5 Then
                    .Axes(xlCategory).TickLabels.Orientation = 0
                    End If
 
 
                 .HasTitle = True
                 .ChartTitle.Select '-------------------------------------------> Mise en Forme Titre
                 .SetElement (msoElementChartTitleAboveChart)
                 .ChartTitle.Characters.Font.Size = 12
                 .ChartTitle.Characters.Font.Color = RGB(0, 0, 0) '------------------------> Fin Mise en Forme Titre
 
                 .Legend.Select '-----------------------------------------------> Mise en Forme Légende
                 .SetElement msoElementLegendRightOverlay
                 .Legend.Top = 32
                 .Legend.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) '---------------------------------------------> Fin Mise en Forme Légende
 
                 .ApplyDataLabels Type:=xlDataLabelsShowValue, AutoText:=True
 
                     For Each Sc In .SeriesCollection '----------------------> Mise en forme des étiquettes de données
 
                     Sc.DataLabels.Format.TextFrame2.TextRange.Font.Bold = msoTrue
                     Sc.DataLabels.Format.TextFrame2.TextRange.Font.Size = 12
                     Sc.DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
                     Sc.DataLabels.Orientation = 45
 
                     If .SeriesCollection.Count = 3 Then
                        .SeriesCollection(1).DataLabels.Position = xlLabelPositionInsideBase
                        .SeriesCollection(3).DataLabels.Position = xlLabelPositionInsideBase
                     End If
 
                     '-----effacer les étiquettes = à 0 ------------------------'
                     q = Sc.Points.Count
                       For w = 1 To q
                         Sc.Points(w).HasDataLabel = True
                         a = Sc.Points(w).DataLabel.Text
                            If a = 0 Then
                            Sc.Points(w).DataLabel.Delete
                            End If
                       Next w
                      '-----fin de effacer les étiquettes = à 0 ------------------------'
 
 
                     Next Sc '--------------------------------------------------> fin Mise en forme étiquettes de données
 
                 End With '-------------------------------------------------------------------------------------------------> Fin Mise en forme NOUVEAU graphique
 
 End If
 
'''''''''''''''''-----------------FIN IV - b) SI GRAPHIQUE ----------------------------'''''''''''''''''
'''''''''''''''''----------------------------------------------------------------------'''''''''''''''''
 
      '---------------------IV - C) Placement de la shape ---------------------'
      '--------------------------------------------------------------------------'
With PptApp.ActivePresentation.Slides(sn + 1).Shapes(NbShpe)
    If .HasChart = True Then
    .Left = 28
    .Height = 400
    .Width = 730
    .Top = 80
    .Line.Visible = msoFalse
    End If
End With
      '------------------------- Fin Placement de la shape ----------------------'
      '--------------------------------------------------------------------------'
 
End If
 
'''''''''''''''''''''''''''''''''''''''FIN IV) ON INSERT SUR UNE NOUVELLE SLIDE''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''-------------------------------------------------------------------------------------------'''''''''''''''''
 
'PptDoc.Close
'Set PptDoc = PptApp.Presentations.Close
'PptDoc.Slides(pn).Select
 
PptApp.ActiveWindow.ViewType = ppViewNormal
End Sub
 
Private Sub Frame1_Click()
 
End Sub
 
Private Sub Label1_Click()
 
End Sub
 
Private Sub TextBox1_Change()
 
End Sub
 
Private Sub UserForm_Click()
 
End Sub

Lorsque j'enlève la zone où ça plante, la macro fonctionne. Mais du coup, le placement de mes graphiques ne se fait pas (car PPT plante que lorsqu'il y a l'ajout d'un graphique). Partie III)a) et III)c)

Ci-joint une photo de mon UserForm

J'espère avoir été clair et n'hésitez pas à me poser des questions si vous ne comprenez pas quelque chose. Je suis débutant en VBA, c'est pourquoi vous trouverez peut-être quelques redondances dans le code.

Pour information :

Dans l'étape III) a). J'ai interverti le 1. et 2.

Ca a fonctionné pendant quelques essais (4 ou 5). Maintenant, PPT re-cesse de fonctionner...

Je ferme tout, ré-ouvre tout ça refonctionne... Lorsque j'ai un PPT contenant plus de graphiques, PPT cesse de fonctionner à nouveau...

Je commence à croire que ça provient d'un manque de puissance de l'ordinateur que j'utilise.

On pourrait tester de ralentir l'enchainement des tâches VBA...

Savez-vous comment faire ?

Cordialement

[Arkham46]

Bonjour,

Le For Each sur SeriesCollection n'est peut-être pas le plus fiable.
En debug on voit que Sc est un type d'objet IMsoSeries, qui un type chaché.

Sc n'est d'ailleurs pas déclaré.

Peut-être qu'une déclaration serait utile :

Code :

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

Dim Sc as Object

Sinon d'après l'aide, il faut lire SeriesCollection par un indice.

Code :

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

1
2
3
4
5
6
 
Dim lCpt As Long
            For lCpt = 1 To .SeriesCollection.Count
              Set Sc = .SeriesCollection(lCpt)
              Sc.DataLabels.Format.TextFrame2.TextRange.Font.Size = 12
            Next Sc

En procédant ainsi, Sc est de type Series, donc ça peut changer quelque chose.

A tester...

Penser aussi à installer le dernier service pack (SP2) si nécessaire.

[Marneus22]

Salut Arkham46


Un grand merci pour ta réponse.

Après avoir déclaré Sc en tant qu"object, PPT ne plante plus. Je l'ai testé une paire de fois, et tout fonctionne.

Je vais encore le tester et rajouter plein de données pour charger les graphiques et vraiment pousser la macro à bout. Si ça fonctionne je clos le sujet. Sinon, je teste avec l'indice lCpt !

Un grand merci pour avoir pris le temps de lire mon code.

[illight]

Comme quoi les déclarations de variables sont vraiment importantes parfois

[Marneus22]

Bon, en ne déclarant que la variable Sc au bout de quelques essais, ça ne fonctionnait plus.

Du coup, j'ai ajouté l'indice lCpt que propose Arkham46.

J'ai de nouveau resollicité la macro avec de gros graphiques !

Malheureusement, PPT a cessé de fonctionner une nouvelle fois mais après de nombreux essais.

Ce ne fonctionne tjrs pas, mais le taux de plantage à considérablement diminué.... ça reste positif quand même

[Marneus22]

Bon, plus de plantage depuis un bon moment... je clos le sujet !

Un grand merci à vous : Arkham46, illight, EngueEngue, Marc-L