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
|
Option Compare Database
Sub creation_PPT()
Dim ppt As PowerPoint.Application
Dim Pres As PowerPoint.Presentation
Dim sl As PowerPoint.Slide
Dim db As Database
Dim t As Recordset
Dim ligne As Long, numDiapo As Long
Set ppt = CreateObject("PowerPoint.Application") 'ouvre powerpoint
ppt.Visible = True
Set Pres = ppt.Presentations.Add 'ouvre un document
Pres.Slides.Add 1, ppLayoutBlank 'crée une diapo vide
Set sl = Pres.Slides(1)
numDiapo = Pres.Slides.Count + 1 'numero pour la diapo suivante
Set tb = sl.Shapes.AddTable(26, 2, 40, 10, 400, 300) 'ajoute une table
tb.Table.Columns(1).Width = 300 'largeur des colonnes
tb.Table.Columns(2).Width = 40
For i = 2 To 26 'mise en forme des cellules (26=nombre de lignes)
For j = 1 To 2 '2=nombre de colonnes
sl.Shapes(1).Table.Rows(i).Cells(j).Shape.TextFrame.TextRange.Font.Size = 10
sl.Shapes(1).Table.Rows(i).Cells(j).Shape.TextFrame.TextRange.Font.Name = "Arial"
Next j
'2eme cellule alignée à droite
sl.Shapes(1).Table.Rows(i).Cells(2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
Next i
Set db = CurrentDb
Set t = db.OpenRecordset("table1") 'ouvre la table 'table1'
t.MoveFirst
ligne = 2
tb.Table.Columns(1).Cells(1).Shape.TextFrame.TextRange.Text = "objet"
tb.Table.Columns(2).Cells(1).Shape.TextFrame.TextRange.Text = "nb"
Do Until t.EOF
'renseigne les cellules avec les données de l'enregistrement en cours
sl.Shapes(1).Table.Columns(1).Cells(ligne).Shape.TextFrame.TextRange.Text = t(0)
sl.Shapes(1).Table.Columns(2).Cells(ligne).Shape.TextFrame.TextRange.Text = t(1)
t.MoveNext 'enregistrement suivant
ligne = ligne + 1 'ligne suivante
If ligne Mod 27 = 0 Then 'crée une nouvelle diapo si tableau plein
Pres.Slides.Add numDiapo, ppLayoutBlank
Set sl = Nothing
Set sl = Pres.Slides(Pres.Slides.Count)
Set tb = Nothing
Set tb = sl.Shapes.AddTable(26, 2, 40, 10, 400, 300) 'ajoute la table
tb.Table.Columns(1).Width = 250
tb.Table.Columns(2).Width = 40
'format des cellules
For i = 2 To 26
For j = 1 To 2
sl.Shapes(1).Table.Rows(i).Cells(j).Shape.TextFrame.TextRange.Font.Size = 10
sl.Shapes(1).Table.Rows(i).Cells(j).Shape.TextFrame.TextRange.Font.Name = "Arial"
Next j
sl.Shapes(1).Table.Rows(i).Cells(2).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
Next i
'titre
tb.Table.Columns(1).Cells(1).Shape.TextFrame.TextRange.Text = "objet"
tb.Table.Columns(2).Cells(1).Shape.TextFrame.TextRange.Text = "nb"
numDiapo = Pres.Slides.Count + 1
ligne = 2
End If
Loop
t.Close 'ferme la table
'sauve le document
Pres.SaveAs "C:\Users\NomUtilisateur\Documents\outils.pptx"
ppt.Quit 'quitte powerpoint
Set ppt = Nothing
End Sub |
Partager