Powerpoint: macro VBA pour sélectionner des cadres textes
Résolu
mag_78
Messages postés
2
Statut
Membre
-
cs_Le Pivert Messages postés 8437 Statut Contributeur -
cs_Le Pivert Messages postés 8437 Statut Contributeur -
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
A voir également:
- Powerpoint vba selection
- Powerpoint viewer - Télécharger - Présentation
- Insérer video powerpoint - Guide
- Powerpoint 2013 - Télécharger - Présentation
- Powerpoint portrait - Guide
- Pagination powerpoint - Guide
2 réponses
Bonjour,
'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
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 SubBon courgae