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
| Sub ppt()
Call Initialisation
Call initialisation_couleurs
Dim ppt As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim Diapo As PowerPoint.Slide
Dim NbShpe, cpt, cpt1, cpt2, cpt_row, cpt_col, fin_cpt As Integer
Dim modelePath, finalPath As Variant
Dim temp As String
Dim ws As Worksheet
Dim c As Chart
modelePath = Application.GetOpenFilename()
Set ppt = CreateObject("PowerPoint.Application") 'creation de l'objet powerpoint
ppt.Visible = True 'active powerpoint
Set ppt = New PowerPoint.Application
If modelePath <> False Then
'ouverture du modèle de présentation
Set pres = ppt.Presentations.Open(Filename:=modelePath)
ws_croises.Previous.Select
fin_cpt = Right(ActiveSheet.Name, 2)
'INITIALISATION DES COMPTEURS
'--------------------------------------------------------------------------------------------------------
cpt = 1
cpt1 = 2
cpt2 = 4
'--------------------------------------------------------------------------------------------------------
ws_taux.Select
While cpt <> fin_cpt + 1
Set Diapo = pres.Slides(cpt2)
pres.Slides(pres.Slides.Count).Duplicate
'AFFICHAGE DES TITRES
'--------------------------------------------------------------------------------------------------------
temp = Mid(ws_taux.Range("C" & cpt1), InStr(ws_taux.Range("C" & cpt1), " ") + 1, Len(ws_taux.Range("C" & cpt1)))
Diapo.Shapes(1).TextFrame.TextRange.Text = temp
'--------------------------------------------------------------------------------------------------------
'AFFICHAGE DES TAUX DE REPONSES
'--------------------------------------------------------------------------------------------------------
If ws_taux.Range("D" & cpt1).Value <> "NS" Then
Diapo.Shapes(3).TextFrame.TextRange.Text = Left(ws_taux.Range("D" & cpt1).Value * 100, 4) & "%"
Else
Diapo.Shapes(3).TextFrame.TextRange.Text = ws_taux.Range("D" & cpt1).Value
End If
'--------------------------------------------------------------------------------------------------------
'AFFICHAGE DES GRAPHIQUES
'--------------------------------------------------------------------------------------------------------
For Each c In wb.Charts
If Left(c.Name, 7) = "Graph" & cpt Then
c.ChartArea.Copy
Diapo.Shapes.PasteSpecial Link:=True
' compte le nombre de shapes dans la diapositive
' le dernier objet inséré correspond à l'index le plus élevé
NbShpe = Diapo.Shapes.Count
'renomme et met en forme l'objet collé
With Diapo.Shapes(NbShpe)
'.Name = "monGraph" 'personnalise le nom
.Left = 125 'définit la position horizontale dans le slide
.Top = 150 'définit la position verticale dans le slide
.Height = 350 'hauteur
.Width = 450 'largeur
End With
End If
Next c
'--------------------------------------------------------------------------------------------------------
'Application.Windows("Outil premiers résultats V20081020_bis.xls").Activate
'AFFICHAGE DES TABLEAUX (SI EXISTANTS)
'--------------------------------------------------------------------------------------------------------
For Each ws In wb.Worksheets
If Left(ws.Name, 5) = "Tab" & cpt Then
cpt_row = 1
cpt_col = 1
While ws.Cells(cpt_row, 1) <> ""
cpt_row = cpt_row + 1
Wend
While ws.Cells(1, cpt_col) <> ""
cpt_col = cpt_col + 1
Wend
Set tabfin = ws.Range(ws.Cells(1, 1), ws.Cells(cpt_row - 1, cpt_col - 1))
tabfin.Copy
Diapo.Shapes.PasteSpecial Link:=True
NbShpe = Diapo.Shapes.Count
'renomme et met en forme l'objet collé
With Diapo.Shapes(NbShpe)
'.Name = "monGraph" 'personnalise le nom
.Left = 125 'définit la position horizontale dans le slide
.Top = 450 'définit la position verticale dans le slide
.Height = 250 'hauteur
.Width = 350 'largeur
End With
End If
Next ws
'--------------------------------------------------------------------------------------------------------
'INCREMENTATION DES COMPTEURS
'--------------------------------------------------------------------------------------------------------
cpt = cpt + 1
cpt1 = cpt1 + 1
cpt2 = cpt2 + 1
'--------------------------------------------------------------------------------------------------------
Wend
'finalPath = Application.GetSaveAsFilename
'If finalPath <> False Then
' pres.SaveAs (finalPath)
'End If
End If
End Sub |
Partager