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
| Option Explicit 'T'oblige a declarer toutes les variables que tu utilises
'Forum DEVELOPPEZ.COM - Auteur : Qwazerty
Sub POWERPOINT()
'Active dans les references (menu option) la ligne "Microsoft PowerPoint x.x Object Library"
Dim objPPT As Object 'POWERPOINT.Application
Dim objPres As Object 'POWERPOINT.Presentation
Dim objSld As Object 'POWERPOINT.Slide
Dim ObjShTable As Object 'POWERPOINT.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer
Dim CustLayout As Object 'POWERPOINT.CustomLayout
Dim TheRow As Variant 'POWERPOINT.Row
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As Object 'POWERPOINT.Shape
Dim TmpTop As Integer
Dim objSldImg As Object
Dim objSldImgTable As Object
Dim ObjShImgTable As Object
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"
Set CustLayout = objPres.SlideMaster.CustomLayouts.Add(1)
'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 si on doit créer un nouveau Slide ou completer l'existant
If NomTableau <> Tablo(i, 2) Then
'On garde en memoire le nom du tableau
NomTableau = Tablo(i, 2)
'On ajoute un nouveau Slide pour insérer les données
Set objSld = objPres.Slides.AddSlide(objPres.Slides.Count + 1, CustLayout)
'On renseigne le titre du slide
objSld.Shapes.Title.TextFrame.TextRange.Text = Tablo(i, 2)
'On ajoute un nouveau slide pour insérer l'image
Set objSldImg = objPres.Slides.AddSlide(objPres.Slides.Count + 1, CustLayout)
'on crée un tableau d'une seule cellule pour recevoir l'image
Set ObjShImgTable = objSldImg.Shapes.AddTable(1, 1)
'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, 19)) 'insertion de l'image correspondante
End With
End If
'On crée le tableau qui contiendra les données avec 2 ligne 3 colonnes ou 1 ligne 3 colonnes
If Tablo(i, 12) <> "" Then
Set ObjShTable = objSld.Shapes.AddTable(2, 3)
Else 'Si pas de sous element precisé
Set ObjShTable = objSld.Shapes.AddTable(1, 3)
End If
'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 = 480
'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, 6) 'Qte
.Cell(1, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 7) 'Description
'On place le sous-ensemble uniquement s'il existe
If Tablo(i, 12) <> "" Then
.Cell(2, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 11) 'Qte
.Cell(2, 3).Shape.TextFrame.TextRange.Text = Tablo(i, 12) 'Description
End If
End With
Next
objPres.save
objPres.Close
End Sub |
