Makro zum Objektverkleinern in Powerpoint 2007

Computer: Software & Programmierung Office Software
#1

Hallo,

ich habe folgendes Problem: ich habe aus anderen Programmen Bildschirmkopien gemacht und diese in eine Powerpointdatei (2007) eingefügt (jeweils eine Kopie pro Blatt). Jetzt möchte ich diese gerne ausdrucken. Die Kopie ist aber zu groß, d.h. ich muss das Objekt erst noch auf das normale Format (A4) verkleinern. Da ich aber über 50 Seiten habe, ist das manuell sehr zeitaufwändig. Daher möchte ich dies über ein Makro machen. Ich habe auch mal bei einer älteren Powerpoint-Version ein Makto geschrieben/aufgenommen (s.u.), das aber nicht mehr funktioniert. Könnte mir jemand helfen, dieses wieder zum Laufen zu bekommmen? Idealerweise sollte irgendwo noch einstellbar sein, wieviele Seiten er verkleinern soll.

Sub BildKopie()
’
ActiveWindow.Selection.SlideRange.Shapes.SelectAll
With ActiveWindow.Selection.ShapeRange
.IncrementLeft 253.25
.IncrementTop 162.88
End With
With ActiveWindow.Selection.ShapeRange
.ScaleWidth 0.63, msoFalse, msoScaleFromBottomRight
.ScaleHeight 0.63, msoFalse, msoScaleFromBottomRight
End With
With ActiveWindow.Selection.ShapeRange
.IncrementLeft -465#
.IncrementTop -330.12
End With
With ActiveWindow.Selection.ShapeRange
.ScaleWidth 1.11, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.11, msoFalse, msoScaleFromTopLeft
End With
End Sub

Oliver

#2

Hallo Oliver,

hier beispielhaft ein Makro. Ich bin davon ausgegangen, dass die eingefügten Screenshots jeweils das einzige/letzte Shapeobjekt auf den Folien sind.

Gruß
Franz

Sub ScreenShotsverkleinern()
 Dim objPres As Presentation
 Dim objSlide As Slide
 Dim objShape As Shape
 Dim intI As Integer, cmToPt As Double
 Dim RandO As Double, RandL As Double, RandU As Double, RandR As Double
 Dim SlideHeight As Double, Slidewidth As Double
 cmToPt = 28.346 'Pt/cm, Umrechnung Points in cm (72 Pt / 2.54 cm)
 Set objPres = ActivePresentation
 SlideHeight = objPres.PageSetup.SlideHeight
 Slidewidth = objPres.PageSetup.Slidewidth
 RandO = 1 \* cmToPt 'Rand Oben
 RandU = 0.5 \* cmToPt 'Rand Unten
 RandL = 0.5 \* cmToPt 'Rand Links
 RandR = 0.5 \* cmToPt 'Rand Rechts
 For intI = 2 To objPres.Slides.Count '2 ggf. anpassen
 Set objSlide = objPres.Slides(intI)
 Set objShape = objSlide.Shapes(objSlide.Shapes.Count)
 With objShape
 .LockAspectRatio = msoTrue
 .Top = RandO
 .Left = RandL
 'Breite und/oder Höhe anpassen
 If .Width \> Slidewidth - (RandL + RandR) Then .Width = Slidewidth - (RandL + RandR)
 If .Height \> SlideHeight - (RandO + RandU) Then .Height = SlideHeight - (RandO + RandU)
 'Shape auf Folie zentrieren
 .Top = RandO + (SlideHeight - RandO - RandU - .Height) / 2
 .Left = (Slidewidth - .Width) / 2
 End With
 Next

End Sub