numerotation des Shapes [FAQ] [Résolu]

[ouioui_cmoi]

Bonjour
Pour supprimer des Shapes, j'utilise le code suivant :

Code :

1
2
3
For Each Shapes In PptDoc.Slides(2).Shapes
   PptDoc.Slides(2).Shapes(1).Delete
    Next

Mais, j'ai plusieurs shapes par page, et je n'arrive pas du tout à comprendre le systeme de numerotation de powerpoint, et du coup, je supprime les mauvaises shapes...
Quelqu'un pourrait t il m'expliquer comment Powerpoint les numerote,s il vous plait?

[Philippe JOCHMANS]

Bonjour

PowerPoint numérote les shapes dans l'ordre de création, et non de la position de celles-ci sur la feuille.

Avec ton code tu supprimes la première qui a été crée, si tu relances ton code tu supprimes la deuxième crée qui est devenue la première car tu as supprimé l'autre avant.

Les solutions :

• Supprimer le type de shapes : PowerPoint nomme les shapes Rectangle1, Oval 1, et ainsi de suite, le numéro s'incrémentant au fur et à mesure, met ne se met pas à zéro.
• Nommer tes shapes lors de la création par le code.

Sous PowerPoint 2007 une nouvelle fonction permet de nommer les shapes en leur donnant un nom significatif, ce qui permet de les désigner sans problème.

Si tu détaillais un peu plus le but de ta suppression et ce que tu veux faire, on pourrait peut-être trouver une solution.

Starec

[ouioui_cmoi]

En fait voila, je t'explique le probleme:
J'ai créé une macro qui exporte des Tableaux et Graphiques vers powerpoint.
Mon code permet d'actualiser un fichier powerpoint:
Donc il est lancé a peu pres chaque semaine. Mon code nomme les tableaux et graphes qu'il colle dans powerpoint.
Si on ne fait que lancer la macro, ma macro cherche dans powerpoint les noms que j'ai donné aux tableaux, et colle les nouveaux.
La macro marche sans problème.
Néanmoins, il arrive à mes collègues de deevoir copier-coller ces tableaux et graphiques à la main, et alors, le nom n'est plus reconnu, et le programme plante, car il ne trouve pas l'objet à supprimer...
Voila mon probleme
J'ai pas acces au code pour l instant, mais je peux l' envoyer cet aprem si tu veux bien m'aider...

[Philippe JOCHMANS]

Re

Envoyé par ouioui_cmoi

J'ai pas acces au code pour l instant, mais je peux l' envoyer cet aprem si tu veux bien m'aider...

Sans problème, par contre quelle version de PPT as-tu ?
De plus ce sera ce soir ou demain matin.

Starec

[ouioui_cmoi]

lol j'ai la version :
Powerpoint 2002 SP3

Et ok ce sera ce soir ou demain matin, pas de pb
merci d avance

[ouioui_cmoi]

Voila le code...

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
Public Sub ModifierPresentationExistantedb()
 
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Set PptApp = CreateObject("Powerpoint.Application")
PptApp.Visible = True
 
 
 
 
With Application.FileSearch
        .NewSearch
        .LookIn = "G:\ 2008\"
        .Filename = "DB*.ppt"
        .Execute
 
       Nombre_Fichier = .FoundFiles.Count
 
       For Each Fichier In .FoundFiles
 
 
        If Fichier = "G:\ 2008\DB " & Format(Now, "yyyy - mm - dd") & ".ppt" Then
        Fichier1 = Fichier
 
       Next
       If Fichier1 = "" Then
       MsgBox ("Fichier DB non trouvé : vérifier que le fichier est de la forme 'DB yyyy - mm - dd' et date de moins de 2 semaines")
       GoTo fin
       End If
 
End With
 
Set PptDoc = PptApp.Presentations.Open(Fichier1)
With PptDoc
 
   Worksheets("DB").Activate
   Range("A1").Select
 
 
a = 3
Do While Cells(a, 1).Value <> ""
    a = a + 1
Loop
a = a + 1
Do While Cells(a, 1).Value <> ""
    a = a + 1
Loop
a = a + 1
Do While Cells(a, 1).Value <> ""
    a = a + 1
Loop
a = a - 1
 
    'tableau
 
    ActiveSheet.Range("A2:H" & a).Copy
 
   PptDoc.Slides(2).Shapes("dbtableau").Delete
    .Slides(2).Shapes.PasteSpecial ppPasteEnhancedMetafile
 
 
    With .Slides(2).Shapes(.Slides(2).Shapes.Count)
        .Name = "dbTableau"
        .LockAspectRatio = msoFalse
        .Width = 360
        .Height = 350
        .Left = 90
        .Top = 130
 
End With
 
    '4 graphes
 
     ActiveSheet.Shapes.Range(Array("Chart 2", "Chart 1", "Chart 4", "Chart 3")).Select
    Selection.Copy
 
 
   PptDoc.Slides(3).Shapes("dbTableau1").Delete
 
    .Slides(3).Shapes.PasteSpecial ppPasteEnhancedMetafile
 With .Slides(3).Shapes(.Slides(3).Shapes.Count)
        .Name = "dbTableau1"
        .LockAspectRatio = msoFalse
        .Width = 700
        .Height = 450
        .Left = 40
        .Top = 70
 
End With
 
    '3 graphes
 
      Worksheets("DB").Activate
    ActiveSheet.Shapes.Range(Array("Chart 7", "Chart 8", "Chart 6")).Select
    Selection.Copy
 
 
   PptDoc.Slides(4).Shapes("dbTableau2").Delete
 
    .Slides(4).Shapes.PasteSpecial ppPasteEnhancedMetafile
 With .Slides(4).Shapes(.Slides(4).Shapes.Count)
        .Name = "dbTableau2"
        .LockAspectRatio = msoFalse
        .Width = 700
        .Height = 460
        .Left = 40
        .Top = 70
 
End With
 
 
   .SaveAs ("G:\ 2008\DB " & Format(Now, "yyyy - mm - dd") & ".ppt")
End With
PptDoc.Close
PptApp.Quit
fin:
 
Finduprog:
Worksheets("DB").Activate
Range("A1").Select
 
End Sub

[Philippe JOCHMANS]

Bonjour

Avant d'aller plus loin, tu vas essayer de lancer le bout de code suivant.

Comme tu dis que tu nommes les objets que tu inséres, lorsque tes collégues insérent des objets, ils ne sont pas nommés.

Hors je te disais précédemment que PPT insére les objets en leur donnant un nom, et en ajoutant un numéro qui s'incrémente.

Le code suivant va boucle sur la diapositives et les formes de ta présentation, ensuite il va faire un test sur le nom, et détruire l'objet s'il s'agit d'un objet nommé par ppt.

Code :

1
2
3
4
5
6
7
8
9
10
11
Public Sub SuppressionObjet()
    Dim shp As Shape
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If Left(shp.Name, 6) = "Object" Then
                shp.Delete
            End If
        Next shp
    Next sld
End Sub

Tu mets ce codes dans un module, tu positionnes le curseur à l'intérieur et tu appuis sur F5.

Cela devrait nettoyer ton fichier.

Starec

[ouioui_cmoi]

J'ai lancé ton programme dans mon powerpoint, mais ca n a pas l'air d avoir d'effet.
Au fait, je n'ai pas précisé: je savais comment supprimer mes shapes lorsque je veux supprimer outes les shapes d'une slide, mais le pb, c'est que, de part la mise en forme du ppt; y a des shapes qu'il ne faut pas que je supprime, et le problème vient de là....

[Philippe JOCHMANS]

Re

Envoyé par ouioui_cmoi

J'ai lancé ton programme dans mon powerpoint, mais ca n a pas l'air d avoir d'effet.

Le petit essai que j'ai fait à fonctionné

Au fait, je n'ai pas précisé: je savais comment supprimer mes shapes lorsque je veux supprimer outes les shapes d'une slide, mais le pb, c'est que, de part la mise en forme du ppt; y a des shapes qu'il ne faut pas que je supprime, et le problème vient de là....

Le code que je t'ai donné sélectionnait les objets par leur nom (donné par ppt) pour les supprimer.
Maintenant à partir du code que je t'ai fourni essayes de faire l'inverse, c'est à dire de tester les noms, et si c'est un nom que tu crées (selon un début de nom par exemple) tu ne fais rien, s'il ne correspond pas à tes critères de nom tu le supprimes.

Starec

[ouioui_cmoi]

j'ai pas le temps de regarder aujourd hui, mais j essaie demain
merci

[ouioui_cmoi]

bon, he bien merci beaucoup, ça marche bien!
J'ai approfondi, et en fait ca marchait pas parce que il fallait que je cherche "picture", et pas object
j ai encore le probleme de lancer la macro pptpar excel, mais j vais faire un nouveau sujet pour ça...
Au fait, dans le même sujet, c'est possible de renommer des shapes existantes dans ppt à la main?

[Philippe JOCHMANS]

Bonjour

Tant mieux si cela fonctionne.

Tu ne peux nommer les shapes à la main, sauf si tu as ppt 2007, c'est une nouvelle fonctionnalité qui est apparue avec cette version.

Si tout est bon, tu cliques sur , et un autre sujet pour de nouvelles aventures sous ppt.

Starec

[ouioui_cmoi]

juste pour savoir: Est il possible de limiter l'exécution de la macro à seulement quelques slide définies?
Parce que, sur mes fichiers powerpoint, j'ai des slides contenant des pictures que je ne veux pas supprimer...
(J'ai beaucoup de mal avec la syntaxe VBA de Powerpoint...)

[Philippe JOCHMANS]

Bonjour

C'est possible, il faut faire un test sur le nom du slide dans ta boucle.

Voici un exemple en reprenant le code que je t'avais donné précedemment, à toi de voir pour l'adapter à ce que tu as fait.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub SuppressionObjet()
 
    Dim shp As Shape
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        Select Case Mid(sld.Name, 6)
            Case 1 To 5
                For Each shp In sld.Shapes
                    If Left(shp.Name, 6) = "Object" Then
                        shp.Delete
                    End If
                Next shp
            Case Else
        End Select
    Next sld
End Sub

on récupére le numéro du slide

Code :

Mid(sld.Name, 6)

Grâce à l'instruction select case, on ne fait l'opération que pour les slides 1 à 5, pour le reste rien.

Starec

[ouioui_cmoi]

OK Merci, j pense ca devrait marcher.
Me reste plus que le probleme de lancer ma macro sur powerpoint a partir d excel...(Sujet créé mais sans réponse...)
Donc si tu avais une idée ce serait cool! ;=)

[ouioui_cmoi]

bonjour
je voulais savoir s'il y avait moyen de mettre ce code directement dans excel, plutôt que de le mettre dans powerpoint et l'ouvrir avec excel , parce que j ai l impression que l'appel de la macro est très lent...
donc j'ai mis le code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
Dim shp As Shape
    Dim sld As Slide
    For Each sld In PptDoc.Slides
        Select Case Mid(sld.Name, 8)
            Case 1 To 2
                For Each shp In sld.Shapes
                    If Left(shp.Name, 7) = "Picture" Then
                        shp.Delete
                    End If
                Next shp
            Case Else
        End Select
    Next sld

dans ma macro excel qui commence avec :

Code :

1
2
Set PptDoc = PptApp.Presentations.Open(Fichier1)
With PptDoc

mais ca ne marche pas...

[ouioui_cmoi]

quelqu'un aurait il une idee?

[Philippe JOCHMANS]

Envoyé par ouioui_cmoi

quelqu'un aurait il une idee?

Cool, on ne peut pas tout faire à la fois (du Access, du Excel et du PPT)

Essayes cela

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Dim App As PowerPoint.Application
Dim Presentation As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
 
Set App = New PowerPoint.Application
App.Visible = True
 
Set Presentation = App.Presentations.Open(Fichier1)
 
For Each sld In App.ActivePresentation.Slides
    Select Case Mid(sld.Name, 8)
        Case 1 To 2
            For Each shp In sld.Shapes
                If Left(shp.Name, 7) = "Picture" Then
                    shp.Delete
                End If
            Next shp
        Case Else
    End Select
Next sld

N'oublies pas de fermer ton ppt à la fin et de cocher la référence Microsoft PowerPoint.

Starec

[ouioui_cmoi]

Eh bien le programme se lance maintenant, mais ne marche absolument pas systematiquement...et se comporte bizarrement:
J'ai un Ppt de 3 slides, alors je met Case 2 car mes tableaux sont en slide 2 et ca ne m'efface rien
j ai alors incremente, et il faut que je mette case 4 pour qqu'il se passe quelque chose...
Le problème, c'est que, sur les 3 tableaux que je veux supprimer, il n'en supprime que 2.
Ce qui n'est pas du tout cohérent:
J'ai mis le code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Set PptApp = CreateObject("Powerpoint.Application")
PptApp.Visible = True
Set PptDoc = PptApp.Presentations.Open(Fichier1)
With PptDoc
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
For Each sld In PptApp.ActivePresentation.Slides
    Select Case Mid(sld.Name, 8)
        Case 4
    For Each shp In sld.Shapes
                If Left(shp.Name, 7) = "Picture" Then
                    shp.Delete
                End If
            Next shp
        Case Else
    End Select
Next sld

Si tu pouvais m'expliquer ce qui se passe ... parce que je ne vois pas la logique, là...lol

[Philippe JOCHMANS]

Bonjour

Ce qui se passe, c'est que tu as du supprimé des slides.

En fait PPT fait la numérotation des slides comme les contrôles que tu ajoutes.

Ainsi si tu mets 4 slides (slides1, slides2, slides3, slides4), si tu supprimes le premier, les autres ne seront pas numérotées, et le slides2 apparaitra le premier alors que tu cherches le case sur le 1 qui n'existe plus, pas cool.

Je vais regarder ce que l'on peut faire.

Starec