Piloter POWERPOINT depuis Excel - Ajouter un nouveau slide après la 12ème ligne

**fidecourt** · 29/01/2011, 17h26

re-bonjour,

voici mon second problème
dans une autre macro qui génère aussi un diaporama PPT, j'ai beaucoup de lignes à mon tableau
il faudrait donc qu'après la 12ème ligne du tableau, je crée un nouveau slide à la suite en reprenant le modèle initial

encore une fois je suis perdue dans le code à générer !

voici le code qui devrait créer le nouveau slide après la 12ème ligne :

Code :

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

1
2
3
4
5
6
7
8
9
For y = 1 To xLigne Step 12
           objSld.Add
 
            For j = y To y + 11
            Rows.Add
                If j >= xLigne Then Exit Sub
 
            Next j
            Next y

==========
j'ai mis en Dim : Dim Ligne As Long
==========
Mais j'ai toujours ma liste sans saut de page ?

Où dois-je intégrer ce code pourqu'il soit efficace ?
voici le code complet de la macro :

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
Sub PPTlisteAgrSautPage()
 
Dim objPPT As PowerPoint.Application  'Object
Dim objPres As PowerPoint.Presentation ' Object
Dim objSld As PowerPoint.SlideRange ' Object
Dim objShp As PowerPoint.Shape ' Object
Dim shp As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer, y As Integer, j As Integer
Dim Ligne As Long
 
 
With Sheets("AgrementsListeTriee")
    Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
Set objPres = objPPT.Presentations.Open(ThisWorkbook.Path & "\ListeAgr.pptx")
objPres.SaveAs ThisWorkbook.Path & "\Agrements.pptm"
 
 
 
 
    'duplique le slide 1
    Set objSld = objPres.Slides(1).Duplicate
    'On le place au dessous de tout
    objSld.moveto objPres.Slides.Count
    'remplit le tableau du slide avec les données
 
    For Each objShp In objSld.Shapes
 
 
     For i = 1 To UBound(Tablo)
        If objShp.HasTable Then
 
            With objShp.Table
                .Cell(2, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'Famille Col A
                .Cell(2, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Calibre Col B
                .Cell(2, 3).Shape.TextFrame.TextRange.Text = (Tablo(i, 7) & "/" & Tablo(i, 10) & "/" & Tablo(i, 12) & "/" & Tablo(i, 14) & "/" & Tablo(i, 16)) 'Agrément1 Col F
                .Cell(2, 4).Shape.TextFrame.TextRange.Text = Tablo(i, 9) 'Designation produit1 Col H
                .Cell(2, 5).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'Classe Col C
                .Cell(2, 6).Shape.TextFrame.TextRange.Text = Tablo(i, 8) 'Distance sécurité1 Col G
                .Cell(2, 7).Shape.TextFrame.TextRange.Text = Tablo(i, 5) 'PT MA Col D
                '=============================================================================
                 x = 0
                Do
                If Tablo(i, 1) <> "" Then
                       .Rows.Add
 
                .Cell(2 + (1 * x), 1).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'Famille Col A
                .Cell(2 + (1 * x), 2).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Calibre Col B
                .Cell(2 + (1 * x), 3).Shape.TextFrame.TextRange.Text = (Tablo(i, 7) & "   " & Tablo(i, 10) & "   " & Tablo(i, 12) & "   " & Tablo(i, 14) & "   " & Tablo(i, 16)) 'Agrément1 Col F
                .Cell(2 + (1 * x), 4).Shape.TextFrame.TextRange.Text = Tablo(i, 9) 'Designation produit1 Col H
                .Cell(2 + (1 * x), 5).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'Classe Col C
                .Cell(2 + (1 * x), 6).Shape.TextFrame.TextRange.Text = Tablo(i, 8) 'Distance sécurité1 Col G
                .Cell(2 + (1 * x), 7).Shape.TextFrame.TextRange.Text = Tablo(i, 5) 'PT MA Col D
 
           For y = 1 To xLigne Step 12
           objSld.Add
 
            For j = y To y + 11
            Rows.Add
                If j >= xLigne Then Exit Sub
 
            Next j
            Next y
 
 
                End If
                    'End If
                    'et autant de fois qu'il y a de lignes où cell B = G
                    i = i + 1
                    x = x + 1
                    If i > UBound(Tablo) Then Exit Do
                Loop While Tablo(i, 1) <> ""
 
 
 
 
                End With
        End If
 
    Next
Next
 
objPres.Slides(1).Delete
objPres.save
objPres.Close
 
End Sub

quelqu'un a-t-il une idée ?
merci pour votre aide

**Qwazerty** · 31/01/2011, 13h00

SAlut

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
Option Explicit 'T'oblige a declarer toutes les variables que tu utilises
'Forum DEVELOPPEZ.COM - Auteur : Qwazerty
Sub BoucleTest2Conditions()
'Active dans les references (menu option) la ligne "Microsoft PowerPoint x.x Object Library"
 
Dim objPPT As powerpoint.Application
Dim objPres As powerpoint.Presentation
Dim objSld As powerpoint.Slide
Dim objSldImg As powerpoint.Slide 'Object
Dim ObjShTable As powerpoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer
'Dim CustLayout As POWERPOINT.CustomLayout
Dim TheRow As powerpoint.Row
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As powerpoint.Shape
'Dim objSldImgTable As POWERPOINT.Slide 'Object
Dim ObjShImgTable As powerpoint.Shape ' Object
Dim TmpTop As Integer
Dim NbrLigne As Byte
Dim AskNewSlide As Boolean
Const cstNbrMaxLigne As Byte = 12
Dim NbrLigneAdded As Byte
Dim sTitre As String
 
 
With Sheets("description-prod") 'Il faut presiser le "." dans la suite du code pour y faire reference
    Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
'Set objPres = objPPT.Presentations.Open(ThisWorkbook.Path & "\note2.pptm")
 
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\test3.ppt"
 
'On charge le modele
objPres.ApplyTemplate ThisWorkbook.Path & "\DEVIS-PPT.potx"
 
 
'Si tu veux changer les couleur sur ous tes Slide, il faut modifier CustLayout
'Ca affectera directement la présentation des slides
For i = 1 To UBound(Tablo)
    'On regarde le nombre de lignes qui devront etre rajoutées au tableau
    If Tablo(i, 6) <> "" Then NbrLigneAdded = 2 Else NbrLigneAdded = 1
    AskNewSlide = CBool(NbrLigne + NbrLigneAdded > cstNbrMaxLigne)
    'On regarde si on doit créer un nouveau Slide ou completer l'existant
    If (NomTableau <> Tablo(i, 2)) Or AskNewSlide Then
        'RéInit
        NbrLigne = 0
 
        'On garde en memoire le nom du tableau si celui-ci a changé
        If NomTableau <> Tablo(i, 2) Then NomTableau = Tablo(i, 2)
 
        If AskNewSlide Then sTitre = Tablo(i, 2) & " (Suite...)" Else sTitre = Tablo(i, 2)
 
        'On ajoute un nouveau Slide
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = sTitre
 
        'On ajoute un nouveau slide pour insérer l'image
        Set objSldImg = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(7))
 
        'on crée un tableau d'une seule cellule pour recevoir l'image
        Set ObjShImgTable = objSldImg.Shapes.AddTable(1, 1)
        'On format le tableau avec un style vierge
        ObjShImgTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
        'ObjShImgTable.Table.Style
        'on dimensionne la cellule pour l'image
        With ObjShImgTable.Table
            .Columns(1).Width = 500
            .Rows(1).Height = 350
'           .Cell(1, 1).Shape.Fill.UserPicture Tablo(i, 7) 'insertion de l'image correspondante 'Ne fonctionne pas chez moi la valeur de Tablo est vide
         End With
 
 
    End If
 
    'On crée le tableau qui contiendra les données avec 2 lignes 3 colonnes ou 1 ligne 3 colonnes
    Set ObjShTable = objSld.Shapes.AddTable(NbrLigneAdded, 3)
 
    'On ajoute le nombre de ligne a jouté au total de ligne du tableau
    NbrLigne = NbrLigne + NbrLigneAdded
 
    'On format le tableau avec un style vierge
    ObjShTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
    'On regarde si des objet tableau existe et on le rajoute a la suite du plus bas
    NewTop = ObjShTable.Top
    For Each TheShTab In objSld.Shapes
        If TheShTab.HasTable And (TheShTab.Name <> ObjShTable.Name) Then
            TmpTop = TheShTab.Top + TheShTab.Height
            If NewTop < TmpTop Then NewTop = TmpTop + 3
        End If
    Next
    ObjShTable.Top = NewTop
 
    'On dimensionne la taille des colonnes (a toi de voir)
    With ObjShTable.Table
        .Columns(1).Width = 40
        .Columns(2).Width = 40
        .Columns(3).Width = 400
 
        'On Rajoute les données article
        'On fusionne les 2 dernieres cellules de a ligne 1
        .Cell(1, 2).Merge .Cell(1, 3)
        'On place l'item principal
        .Cell(1, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Qte
        .Cell(1, 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'Description
        .Cell(1, 2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        'On place le sous-essemble uniquement s'il existe
        If NbrLigneAdded = 2 Then
            .Cell(2, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 5) 'Qte
            .Cell(2, 3).Shape.TextFrame.TextRange.Text = Tablo(i, 6) 'Description
        End If
    End With
 
 
Next
 
objPres.Save
objPres.Close
 
End Sub

++
Qwaz

**fidecourt** · 31/01/2011, 17h32

alors c'est presque ça...
en effet, il crée bien un nouveau slide en insérant le bon titre avec (suite) si + de 12 lignes dans le tableau

mais comme il compte les lignes de la col B où se trouve le nom du tableau
il ne prend pas en compte les lignes générées par les descriptions 2 (col L)

ce qui fait que si le tableau a des descriptions 2
lorsqu'il passe au tableau suivant, il met le bon titre mais rajoute (suite)

il faudrait dans :
===
Const cstNbrMaxLigne As Byte = 10
====
lui indiquer de calculer les lignes de col 2 (B) + les lignes de col 12 (L) si <> ""
====

comment expliquer cela de façon rationnelle à la macro ?
et est-ce possible ?

tu vois le truc ??

**Qwazerty** · 31/01/2011, 17h53

SAlut
Je ne comprend pas trop pourquoi tu me parles de données colonne 12.

J'ai modifié le code pour qu'il n'y ait qu'une image par type de tableau.

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
Option Explicit 'T'oblige a declarer toutes les variables que tu utilises
'Forum DEVELOPPEZ.COM - Auteur : Qwazerty
Sub BoucleTest2Conditions()
'Active dans les references (menu option) la ligne "Microsoft PowerPoint x.x Object Library"
 
Dim objPPT As powerpoint.Application
Dim objPres As powerpoint.Presentation
Dim objSld As powerpoint.Slide
Dim objSldImg As powerpoint.Slide 'Object
Dim ObjShTable As powerpoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer
'Dim CustLayout As POWERPOINT.CustomLayout
Dim TheRow As powerpoint.Row
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As powerpoint.Shape
'Dim objSldImgTable As POWERPOINT.Slide 'Object
Dim ObjShImgTable As powerpoint.Shape ' Object
Dim TmpTop As Integer
Dim NbrLigne As Byte
Dim AskNewSlide As Boolean
Const cstNbrMaxLigne As Byte = 10
Dim NbrLigneAdded As Byte
Dim sTitre As String
 
 
With Sheets("description-prod") 'Il faut presiser le "." dans la suite du code pour y faire reference
    Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
'Set objPres = objPPT.Presentations.Open(ThisWorkbook.Path & "\note2.pptm")
 
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\test3.ppt"
 
'On charge le modele
objPres.ApplyTemplate ThisWorkbook.Path & "\DEVIS-PPT.potx"
 
 
'Si tu veux changer les couleur sur ous tes Slide, il faut modifier CustLayout
'Ca affectera directement la présentation des slides
For i = 1 To UBound(Tablo)
    'On regarde le nombre de lignes qui devront etre rajoutées au tableau
    If Tablo(i, 6) <> "" Then NbrLigneAdded = 2 Else NbrLigneAdded = 1
    AskNewSlide = CBool(NbrLigne + NbrLigneAdded > cstNbrMaxLigne)
    'On regarde si on doit créer un nouveau Slide ou completer l'existant
    If (NomTableau <> Tablo(i, 2)) Or AskNewSlide Then
        'RéInit
        NbrLigne = 0
        sTitre = Tablo(i, 2)
        'On garde en memoire le nom du tableau si celui-ci a change
        If NomTableau <> Tablo(i, 2) Then
            NomTableau = Tablo(i, 2)
        Else
            If AskNewSlide Then sTitre = sTitre & " (Suite...)"
        End If
 
        'On ajoute un nouveau Slide
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = sTitre
 
        If AskNewSlide Then 'Si on poursuit un tableau sur un autre slide, on supprime le slide Image precedent
            objSldImg.Delete
        End If
 
        'On ajoute un nouveau slide pour insérer l'image
        Set objSldImg = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(7))
 
        'on crée un tableau d'une seule cellule pour recevoir l'image
        Set ObjShImgTable = objSldImg.Shapes.AddTable(1, 1)
 
        'On format le tableau avec un style vierge
        ObjShImgTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
        'on dimensionne la cellule pour l'image
        With ObjShImgTable.Table
            .Columns(1).Width = 500
            .Rows(1).Height = 350
'           .Cell(1, 1).Shape.Fill.UserPicture Tablo(i, 7) 'insertion de l'image correspondante 'Ne fonctionne pas chez moi la valeur de Tablo est vide
        End With
 
    End If
 
    'On crée le tableau qui contiendra les données avec 2 lignes 3 colonnes ou 1 ligne 3 colonnes
    Set ObjShTable = objSld.Shapes.AddTable(NbrLigneAdded, 3)
 
    'On ajoute le nombre de ligne a jouté au total de ligne du tableau
    NbrLigne = NbrLigne + NbrLigneAdded
 
    'On format le tableau avec un style vierge
    ObjShTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
    'On regarde si des objet tableau existe et on le rajoute a la suite du plus bas
    NewTop = ObjShTable.Top
    For Each TheShTab In objSld.Shapes
        If TheShTab.HasTable And (TheShTab.Name <> ObjShTable.Name) Then
            TmpTop = TheShTab.Top + TheShTab.Height
            If NewTop < TmpTop Then NewTop = TmpTop + 3
        End If
    Next
    ObjShTable.Top = NewTop
 
    'On dimensionne la taille des colonnes (a toi de voir)
    With ObjShTable.Table
        .Columns(1).Width = 40
        .Columns(2).Width = 40
        .Columns(3).Width = 400
 
        'On Rajoute les données article
        'On fusionne les 2 dernieres cellules de a ligne 1
        .Cell(1, 2).Merge .Cell(1, 3)
        'On place l'item principal
        .Cell(1, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Qte
        .Cell(1, 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'Description
        '.Cell(1, 2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        'On place le sous-essemble uniquement s'il existe
        If NbrLigneAdded = 2 Then
            .Cell(2, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 5) 'Qte
            .Cell(2, 3).Shape.TextFrame.TextRange.Text = Tablo(i, 6) 'Description
        End If
    End With
 
 
Next
 
objPres.Save
objPres.Close
 
End Sub

++
Qwaz

**fidecourt** · 31/01/2011, 19h19

je te joins le fichier de test avec les données
si tu fais la macro, tu verras en slide 8 ce que cela donne par rapport aux données

http://www.cijoint.fr/cjlink.php?fil...cij5BXlzZ4.zip

A+

**Qwazerty** · 31/01/2011, 19h48

Aller Françoise, un petit effort d'adaptation, tu n'as pas tenu compte de mes modifs sur le code précédent

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
Option Explicit 'T'oblige a declarer toutes les variables que tu utilises
'Forum DEVELOPPEZ.COM - Auteur : Qwazerty
Sub BoucleTest2Conditions()
'Active dans les references (menu option) la ligne "Microsoft PowerPoint x.x Object Library"
 
Dim objPPT As PowerPoint.Application
Dim objPres As PowerPoint.Presentation
Dim objSld As PowerPoint.Slide
Dim objSldImg As PowerPoint.Slide 'Object
Dim ObjShTable As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer
Dim TheRow As PowerPoint.Row
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As PowerPoint.Shape
Dim ObjShImgTable As PowerPoint.Shape ' Object
Dim TmpTop As Integer
Dim NbrLigne As Byte
Dim AskNewSlide As Boolean, SameTableau As Boolean
Const cstNbrMaxLigne As Byte = 10
Dim NbrLigneAdded As Byte
Dim sTitre As String
 
 
With Sheets("description-prod") 'Il faut presiser le "." dans la suite du code pour y faire reference
    Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
 
Set objPres = objPPT.Presentations.Add
objPres.SaveAs ThisWorkbook.Path & "\test3.ppt"
 
'On charge le modele
objPres.ApplyTemplate ThisWorkbook.Path & "\DEVIS-PPT.potx"
 
 
For i = 1 To UBound(Tablo)
    'On regarde le nombre de lignes qui devront etre rajoutées au tableau
    If Tablo(i, 12) <> "" Then NbrLigneAdded = 2 Else NbrLigneAdded = 1
    AskNewSlide = CBool(NbrLigne + NbrLigneAdded > cstNbrMaxLigne)
    SameTableau = CBool(NomTableau = Tablo(i, 2))
    'On regarde si on doit créer un nouveau Slide ou completer l'existant
    If Not SameTableau Or AskNewSlide Then
        'RéInit
        NbrLigne = 0
 
        sTitre = Tablo(i, 2)
        'On garde en memoire le nom du tableau si celui-ci a change
        If Not SameTableau Then
            NomTableau = Tablo(i, 2)
        Else
            If AskNewSlide Then sTitre = sTitre & " (Suite...)"
        End If
 
 
        'On ajoute un nouveau Slide
        Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(6))
 
        'On renseigne le titre du slide
        objSld.Shapes.Title.TextFrame.TextRange.Text = sTitre
 
        If AskNewSlide And SameTableau Then 'Si on poursuit un tableau sur un autre slide, on supprime le slide Image precedent
            objSldImg.Delete
        End If
 
        'On ajoute un nouveau slide pour insérer l'image
        Set objSldImg = objPres.Slides.AddSlide(objPres.Slides.Count + 1, objPres.SlideMaster.CustomLayouts(7))
 
        'on crée un tableau d'une seule cellule pour recevoir l'image
        Set ObjShImgTable = objSldImg.Shapes.AddTable(1, 1)
        'On format le tableau avec un style vierge
        ObjShImgTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 
        'on détermine les marges pour l'image
        With ObjShImgTable
        .Left = 5
        .Top = 5
        End With
 
        'on dimensionne la cellule pour l'image
         With ObjShImgTable.Table
            .Columns(1).Width = 710 'image pleine page avec marge de 5 à gauche et à droite
            .Rows(1).Height = 530 'image pleine page avec marge de 5 en haut et en bas
            'On remplit avec l'image correspondant aux données
'            .Cell(1, 1).Shape.Fill.UserPicture Tablo(i, 19)
        End With
 
    End If
 
 
    'On crée le tableau qui contiendra les données avec 2 lignes 3 colonnes ou 1 ligne 3 colonnes
    Set ObjShTable = objSld.Shapes.AddTable(NbrLigneAdded, 3)
 
 
    'On ajoute le nombre de ligne a jouté au total de ligne du tableau
    NbrLigne = NbrLigne + NbrLigneAdded
 
    'On format le tableau avec un style vierge
    ObjShTable.Table.ApplyStyle "{2D5ABB26-0587-4C30-8999-92F81FD0307C}", True
 'a cet endroit
  With ObjShTable
        .Left = 35
        .Top = 150
        End With
 
 
    'On regarde si des objet tableau existe et on le rajoute a la suite du plus bas
    NewTop = ObjShTable.Top
    For Each TheShTab In objSld.Shapes
        If TheShTab.HasTable And (TheShTab.Name <> ObjShTable.Name) Then
            TmpTop = TheShTab.Top + TheShTab.Height
            If NewTop < TmpTop Then NewTop = TmpTop + 3
        End If
    Next
    ObjShTable.Top = NewTop
 
 
 
    'On dimensionne la taille des colonnes (a toi de voir)
    With ObjShTable.Table
        .Columns(1).Width = 65
        .Columns(2).Width = 65
        .Columns(3).Width = 540
 
        'On Rajoute les données article
        'On fusionne les 2 dernieres cellules de a ligne 1
        .Cell(1, 2).Merge .Cell(1, 3)
        'on aligne la cellule à droite pour recevoir les qtés (nombres)
        .Cell(1, 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        'On place l'item principal
        .Cell(1, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 6) 'Qte
        'on aligne la cellule à gauche pour recevoir les descriptions (texte)
        .Cell(1, 2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
        .Cell(1, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 7) 'Qte
        'On place le sous-essemble uniquement s'il existe
        If NbrLigneAdded = 2 Then
            .Cell(2, 2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
            .Cell(2, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 11) 'Qte
            .Cell(2, 3).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
            .Cell(2, 3).Shape.TextFrame.TextRange.Text = Tablo(i, 12) 'Description
 
        End If
    End With
 
 
Next
 
objPres.Save
'objPres.Close
 
End Sub

Heu au fait, le Slide 8, c'est une image

++
Qwaz

**fidecourt** · 01/02/2011, 08h51

Bonjour Qwazerty !

effectivement j'ai mis à jour ton dernier code et la formule "sameTableau" résoud le souci du titre du tableau (problème que j'évoquais hier dans mon dernier message) pour l'image c'est impec comme cela

désolée, je me suis un peu emmêlée dans le code hier soir

au menu aujourd'hui : réajuster ce même code pour mon tableau des agréments qui pour le moment est basé sur un modèle (tableau de 2 lignes, dont une d'entête) c'est pas gagné !

je ne suis pas sûre d'y arriver seule, mais bon je m'y attèle de ce pas
je clos cette discussion qui aura été plus que profitable pour moi
j'espère qu'elle servira à d'autres, car on ne trouve pas grand chose sur ce sujet dans les docs ou forum

encore merci pour ton aide super efficace

Piloter POWERPOINT depuis Excel - Ajouter un nouveau slide après la 12ème ligne [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager