Powerpoint: macro VBA pour sélectionner des cadres textes

Résolu

mag_78 Messages postés 2 Date d'inscription Statut Membre Dernière intervention -
cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention - 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
Pagination powerpoint - Guide

2 réponses

Réponse 1 / 2

cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention 729

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 Statut Contributeur Dernière intervention 729

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 Statut Membre Dernière intervention > cs_Le Pivert Messages postés 7904 Date d'inscription Statut Contributeur Dernière intervention

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 Statut Contributeur Dernière intervention 729

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

Erreur d'exécution 13 Incompatibilité de type

Changer l'orientation d'une seule diapo

publipostage sur PowerPoint

Votre réponse

Discussions similaires