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
| Option Explicit 'T'oblige a declarer toutes les variables que tu utilises
'Forum DEVELOPPEZ.COM - Auteur : Qwazerty
Sub Devis()
'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 ObjShTable As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer
Dim CustLayout As PowerPoint.CustomLayout
Dim TheRow As Variant
Dim NomTableau As String
Dim NewTop As Integer
Dim TheShTab As 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) '
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, Layout:=ppLayoutBlank)
'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 |
Partager