Hallo,
ich habe eine Powerpoint Folie mit 4 "Grafik"- Platzhalter für mich so verändert, das diese auf der linken Seite untereinander angeordnet sind. Die Seite ist im Hochformat eingerichtet und die Platzhalter haben die Größe 5cm x 8,5 cm.
Das ganze habe ich als Vorlage.ppt abgespeichert, so weit so gut.

Kann ich die Folie im Folienlayout nicht so hinterlegen das ich diese nicht immer neu anpassen muß?

Wenn ich Bilder auswechseln möchte, d.h. Bild löschen um dann ein neues einzufügen, so verändert sich die Größe und Position des Platzhalters.
Das ist blöd, denn ich muß den Platzhalter dann wieder neu positionieren und die Größe neu einrichten.

Nun habe ich mir für das Positionieren und das Anpassen der Größe ein Macro angefertigt. Leider funktiniert es nur für eine Folie da die Rahmen direkt angesprochen werden.

Gibt es eine Möglichkeit das Macro auf eine "aktive" Folie anzuwenden, so das ich auch weitere Folien formatieren kann?

Sub Folie_formatieren() 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 20").Select 
    With ActiveWindow.Selection.ShapeRange 
        .Fill.Transparency = 0# 
        .Height = 141.75 
        .Width = 240.88 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 19").Select 
    With ActiveWindow.Selection.ShapeRange 
        .Fill.Transparency = 0# 
        .Height = 141.75 
        .Width = 240.88 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 18").Select 
    With ActiveWindow.Selection.ShapeRange 
        .Fill.Transparency = 0# 
        .Height = 141.75 
        .Width = 240.88 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 17").Select 
    With ActiveWindow.Selection.ShapeRange 
        .IncrementLeft -0.38 
        .IncrementTop -0.5 
    End With 
    With ActiveWindow.Selection.ShapeRange 
        .Fill.Transparency = 0# 
        .Height = 141.75 
        .Width = 240.88 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 20").Select 
    With ActiveWindow.Selection.ShapeRange 
        .IncrementLeft -0.75 
        .IncrementTop -63.12 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 19").Select 
    With ActiveWindow.Selection.ShapeRange 
        .IncrementLeft -0.75 
        .IncrementTop -153.5 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 18").Select 
    With ActiveWindow.Selection.ShapeRange 
        .IncrementLeft -249.75 
        .IncrementTop 243# 
    End With 
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 17").Select 
    With ActiveWindow.Selection.ShapeRange 
        .IncrementLeft -249.38 
        .IncrementTop 153.12 
    End With 
End Sub