Powerpoint: macro VBA pour sélectionner des cadres textes

Résolu/Fermé

mag_78 Messages postés 2 Date d'inscription mercredi 11 février 2015 Statut Membre Dernière intervention 11 février 2015 - Modifié par pijaku le 12/02/2015 à 08:52
cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 - 12 févr. 2015 à 08:07

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:

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
Réparer fichier powerpoint endommagé gratuit - Télécharger - Suite bureautique

2 réponses

Réponse 1 / 2

cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 729
11 févr. 2015 à 15:14

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

cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 729
11 févr. 2015 à 15:16

Ne 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

mag_78 Messages postés 2 Date d'inscription mercredi 11 février 2015 Statut Membre Dernière intervention 11 février 2015 > cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024
Modifié par pijaku le 12/02/2015 à 08:52

Merci 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

Réponse 2 / 2

cs_Le Pivert Messages postés 7904 Date d'inscription jeudi 13 septembre 2007 Statut Contributeur Dernière intervention 14 août 2024 729
12 févr. 2015 à 08:07

Content 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!

Discussions similaires

"L'indice n'appartient à la sélection" + VBA

erreur d'execution 9, l'indice n'appartient pas à la sélection

l'indice n'appartient pas à la selection

Erreur '9' l'indice n'appartient pas à la sélection

publipostage sur PowerPoint