Powerpoint: macro VBA pour sélectionner des cadres textes
Résolu
Bonjour,
je cherche à créer une macro sous VBA qui sur une feuille powerpoint va sélectionner tous les cadres textes et changer la police de cette sélection globale?
Ma macro est la suivante:
Merci à vous
je cherche à créer une macro sous VBA qui sur une feuille powerpoint va sélectionner tous les cadres textes et changer la police de cette sélection globale?
Ma macro est la suivante:
Sub ModifierPresentationExistante()
Dim PptApp As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim i As Integer
Set PptApp = CreateObject("Powerpoint.Application")
Set PptDoc = PptApp.Presentations.Add
With PptDoc
For i = 1 To 5
'copie la plage de cellules dans la feuille Excel active
Feuil1.Range("B1:H5").Copy
'Effectue un collage dans la diapositive i
.Slides(i).Shapes.Paste
With .Slides(i).Shapes(.Slides(i).Shapes.Count) 'lieu du bugg
Sh.TextFrame.TextRange.Font.Name = "Calibri"
Sh.TextFrame.TextRange.Font.Size = 20
Sh.TextFrame.TextRange.Font.Bold = True
End With
Next
End With
End Sub
Merci à vous
2 réponses
-
ContributeurBonjour,
'cochez la reference Microsoft PowerPoint 11.0 Object Library Option Explicit Private Sub CommandButton1_Click() ModifierPresentationExistante End Sub Sub ModifierPresentationExistante() Dim PptApp As PowerPoint.Application Dim PptDoc As PowerPoint.Presentation Dim Sh As PowerPoint.Shape Dim i As Integer Set PptApp = CreateObject("Powerpoint.Application") Set PptDoc = PptApp.Presentations.Add 'Cree les slides For i = 1 To 5 With PptDoc '--- Ajoute un Slide .Slides.Add Index:=1, Layout:=ppLayoutBlank End With Next 'parcourt les slides With PptDoc For i = 1 To .Slides.Count ' nbre de slides 'copie la plage de cellules de la feuille Excel active Feuil1.Range("B1:H5").Copy 'Effectue un collage dans la diapositive i .Slides(i).Shapes.Paste 'Crée une zone de texte (AddLabel) Set Sh = .Slides(i).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _ Left:=100, Top:=100, Width:=150, Height:=60) Sh.TextFrame.TextRange.Font.Name = "Calibri" Sh.TextFrame.TextRange.Font.Size = 20 Sh.TextFrame.TextRange.Font.Bold = True Next End With 'Sauvegarde la présentation 'dans le meme répertoire que le classeur excel contenant la macro. PptDoc.SaveAs Filename:=ThisWorkbook.Path & "\" & "NouvellePresentation.ppt" 'ferme la presentation PptDoc.Close 'ferme powerpoint PptApp.Quit MsgBox "Opération terminée." End Sub Sub texte() 'Crée une zone de texte (AddLabel) Set Sh = .Slides(i).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _ Left:=100, Top:=100, Width:=150, Height:=60) Sh.TextFrame.TextRange.Font.Name = "Calibri" Sh.TextFrame.TextRange.Font.Size = 20 Sh.TextFrame.TextRange.Font.Bold = True End Sub
-
ContributeurNe pas tenir compte de cette macro
Sub texte() 'Crée une zone de texte (AddLabel) Set Sh = .Slides(i).Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _ Left:=100, Top:=100, Width:=150, Height:=60) Sh.TextFrame.TextRange.Font.Name = "Calibri" Sh.TextFrame.TextRange.Font.Size = 20 Sh.TextFrame.TextRange.Font.Bold = True End Sub
-
@cs_Le PivertMerci pour ton aide mais les tests n'étaient pas concluants, la macro ne selectionnait pas tous les cadres présents
J'ai poursuivi mes efforts et trouver:
Sub modifier_police() Dim nb_slide As Integer Dim nb_cadre As Integer Dim i As Integer Dim j As Integer With ActivePresentation nb_slide = ActivePresentation.Slides.Count For i = 1 To nb_slide nb_cadre = ActivePresentation.Slides(i).Shapes.Count For j = 1 To nb_cadre With ActivePresentation.Slides(i).Shapes(j) With .TextFrame.TextRange.Font .Size = 20 .Name = "Calibri" .Bold = True .Color.RGB = RGB(255, 127, 255) End With End With Next Next End With MsgBox ("police terminée") End Sub
Bon courgae
-
-
ContributeurContent que tu ais résolu ton problème. J'ai simplement corrigé le code que tu avais donné qui n'as rien a voir avec le code ci-dessus.
Nous ne sommes pas des devins, nous travaillons avec les infos données!
