so I have this line of code which works fine for just 1 ppt-file.
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment=ppAlignCenter
How can i make this work for all powerpoint files in the same folder with VBA? So that it knows that it selects the top most TextFrame and then AlignCenters it.
Or even when all PPTs are open if that's easier..
This will select the shape that is positioned closest to the top of the slide:
Option Explicit
' Selects the shape that support text which is closest to the top of the slide
' Written by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub SelectHigestTextShape()
Dim oSld As Slide
Dim oShp As Shape, oShpTop As Shape
Dim sShpTop As Single
On Error Resume Next
Set oSld = ActiveWindow.View.Slide
If Err Then Exit Sub
On Error GoTo 0
' Set the top to the bottom of the slide
sShpTop = ActivePresentation.PageSetup.SlideHeight
' Check each shape on the slide is positioned above the stored position
' Shapes not supporting text and placeholders are ignored
For Each oShp In oSld.Shapes
If oShp.Top < sShpTop And oShp.HasTextFrame And Not oShp.Type = msoPlaceholder Then
sShpTop = oShp.Top
Set oShpTop = oShp
End If
Next
' Select the topmost shape
If Not oShpTop Is Nothing Then oShpTop.Select msoTrue
' Clean up
Set oSld = Nothing
Set oShp = Nothing
Set oShpTop = Nothing
End Sub
Related
In the master layout I defined the placeholders where the images are added, but I can't find a solution to scale to fit them. The reason for the image placeholders is that the pictures can be added for different layouts without adding the exact location properties (Left, Top, Width, Height)
My current code looks like this:
Sub InsertPictures
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
End Sub
In the picture below you can see on the left side how the picture is added with a image placeholder and on the right side how it should be added, when its fitted.
I found a code which does the "crop to fit", but it only works when the slide is selected:
Sub cropFit()
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.View.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
How do I have to change the code that directly after adding the images with the code above (Sub Insert Pictures), the images are cropped to fit in the presentation mode?
Thanks for your help in advance!
What we need to do is get the Picture Placeholders, and assign pictures to those placeholders. You will put your file names in an array that can hold as many strings as placeholders ( I used 3 below because you say you have 3 picture placeholders). Then we will insert the pictures at those placeholders and crop them to fit. I borrowed concepts used here and here. So your code would be:
Sub InsertPictures()
Dim FileNames(1 To 3) As String, Shps As Shapes, i As Integer
Set Shps = ActivePresentation.Slides(1).Shapes
FileNames(1) = "U:\xyz\EAP.png"
FileNames(2) = "U:\xyz\DAP_01.png"
' Filenames(3) = "Blah Blah Blah"
i = 1
For Each Shp In Shps.Placeholders
' You only need to work on Picture place holders
If Shp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With Shp
' Now add the Picture
Set s = Shps.AddPicture(FileNames(i), msoTrue, msoTrue, _
.Left, .Top, .Width, .Height)
' Insert DoEvents here specially for big files, or network files
' DoEvents halts macro momentarily until the
' system finishes what it's doing which is loading the picture file
DoEvents
s.Select
CommandBars.ExecuteMso ("PictureFitCrop")
i = i + 1
End With
End If
If (i > UBound(FileNames)) Then Exit For
If (FileNames(i) = "") Then Exit For
Next Shp
End Sub
Thank you guys for your help! I managed to solve this problem with the following code:
Sub CropToFit()
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
ActivePresentation.SlideShowWindow.view.Exit
Do Events
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.view.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
I have the following macro that aligns 1 selected picture at a time in Power Point:
Sub Align()
With ActiveWindow.Selection.ShapeRange
.Left = 50
.Top = 100
End With
End Sub
This code works if I run the macro on a selected picture in a slide.
But how can I run this script for each picture of all slides?
This will do that for you Jose:
' PowerPoint VBA to reposition all pictures in all slides in a deck
' Written by Jamie Garroch of YOUpresent Ltd.
' http://youpresent.co.uk/
Option Explict
Sub RepositionAllPictures()
Dim oSld As Slide
Dim oShp as Shape
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.Type = msoPicture Then RepositionShape oShp
If oShp.Type = msoPlaceholder Then
If oShp.PlaceholderFormat.ContainedType = msoPicture Or _
oShp.PlaceholderFormat.ContainedType = msoLinkedPicture Then _
RepositionShape oShp
End If
Next
Next
End Sub
Sub RepositionShape(oShp As Shape)
oShp.Left = 50
oShp.Top = 100
End Sub
Good day,
I have got this code to modify the size and position of every shape on all slides, but would like the procedure to start ONLY from slide 2.
Sub SlideLoop()
Dim osld As Slide
Dim oSh As Shape
For Each osld In ActivePresentation.Slides
' check each shape on the slide
' is it an image or whatever you're looking for?
For Each oSh In osld.Shapes
With oSh
If .Type = msoLinkedPicture _
Or .Type = msoPicture Then
' position it to taste
.Left = 30
.Top = 100
.Height = 750
.Width = 680
' centering/resizing gets trickier
' but is still possible.
' Exercise for the reader?
' Hint:
' ActivePresentation.PageSetup.SlideWidth and .SlideHeight
' tells you the width and height of the slide
'
' All values are in Points (72 to the inch)
End If
End With
Next ' Shape
Next osld ' Slide
End Sub}
What do I need to change?
Check the SlideIndex property of the slides - if it is 1, you skip to the next slide.
Just inside the For Each osld In ActivePresentation.Slides loop, add an if statement:
If osld.SlideIndex > 1 Then
'Your code...
For Each oSh In osld.Shapes
...
Next ' Shape
End If
Olle's correct. Or another approach, my changes in BOLD:
Sub SlideLoop()
Dim osld As Slide
Dim oSh As Shape
Dim x as Long
'For Each osld In ActivePresentation.Slides
For x = 2 to ActivePresentation.Slides.Count
Set oSld = ActivePresentation.Slides(x)
' check each shape on the slide
' is it an image or whatever you're looking for?
For Each oSh In osld.Shapes
With oSh
If .Type = msoLinkedPicture _
Or .Type = msoPicture Then
' position it to taste
.Left = 30
.Top = 100
.Height = 750
.Width = 680
' centering/resizing gets trickier
' but is still possible.
' Exercise for the reader?
' Hint:
' ActivePresentation.PageSetup.SlideWidth and .SlideHeight
' tells you the width and height of the slide
'
' All values are in Points (72 to the inch)
End If
End With
Next ' Shape
Next osld ' Slide
End Sub
So I have written the following code to make the textboxes in my presentation visisible and then bring them to the front (they are made invisible by a separate macro):
Dim oSld As Slide
Dim oShp As Shape
Dim oPPT As Presentation
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next oShp
Next oSld
It worked perfectly before I added the bring to front command! Now only around half of the shapes are made visible when the code is run. I've been reading around online and it appears that ZOrder changes the number of shapes and that is why only some are made visible.... but cannot work out a way around it! Would really appreciate some help!
You've put your finger on the cause. The For Each/Next loop appears to take a snapshot of the shape order at the time it starts. If you change the shape order or delete shapes in the body of the loop it throws things off. Instead, try something like the (untested)(air)code below to build an array of references to the shapes and then process them one at a time from the array:
Dim aShapeArray() as Shape
Dim x as Long
ReDim aShapeArray(1 to oSld.Shapes.Count) as Shape
' Build an array of shapes
For Each oShp In oSld.Shapes
Set aShapeArray(x) = oShp
x = x+1
Next
' Then do what you need to do with each shape in the array
For x = 1 to Ubound(aShapeArray)
Set oShp = aShapeArray(x)
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next
Thanks for all your help #SteveRindsberg, a couple a tweaks to your code and i cracked it :)
Dim oSld As Slide
Dim aShapeArray()
Dim x As Long
For Each oSld In ActivePresentation.Slides
x = 1
If oSld.Shapes.Count > 0 Then
ReDim aShapeArray(1 To oSld.Shapes.Count)
' Build an array of shapes
For Each oShp In oSld.Shapes
Set aShapeArray(x) = oShp
x = x + 1
Next
' Then do what you need to do with each shape in the array
For x = 1 To UBound(aShapeArray)
Set oShp = aShapeArray(x)
If oShp.Type = msoTextBox Then
oShp.Visible = True
oShp.ZOrder msoBringToFront
End If
Next
End If
Next
I'm want to perform a variety of formatting options on images in slides.
The macro runs on images that I've SELECTED in a slide, but I'd like to run the macro without selecting the images.
Here's how I'm currently manipulating images (in this case aligning the image to the horizontal center of the slide) and the piece of code that I'm looking for help replacing:
With ActiveWindow.Selection.ShapeRange
.Align (msoAlignCenters), msoTrue
End With
Here's the entire code body so far:
Sub TestCenterImage()
Dim osld As Slide
Dim oshp As Shape
For Each osld In ActivePresentation.Slides
If osld.SlideIndex > 1 Then Exit Sub 'I don't know if I need this line
For Each oshp In osld.Shapes
If CheckIsPic(oshp) = True Then 'Making sure that we're only working with images
With ActiveWindow.Selection.ShapeRange 'The portion of code I need help with
.Align (msoAlignCenters), msoTrue
End With
End If
Next oshp
Next osld
End Sub
Function CheckIsPic(oshp As Shape) As Boolean
If oshp.Type = msoPicture Then CheckIsPic = True
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.ContainedType = msoPicture Then CheckIsPic = True
End If
End Function
Try it this way instead:
Sub TestCenterImage()
Dim osld As Slide
Dim oShp As Shape
For Each osld In ActivePresentation.Slides
'If osld.SlideIndex > 1 Then Exit Sub 'I don't know if I need this line
For Each oShp In osld.Shapes
If CheckIsPic(oShp) = True Then 'Making sure that we're only working with images
CenterOnSlide oShp
'End With
End If
Next oShp
Next osld
End Sub
Function CheckIsPic(oShp As Shape) As Boolean
If oShp.Type = msoPicture Then CheckIsPic = True
If oShp.Type = msoPlaceholder Then
If oShp.PlaceholderFormat.ContainedType = msoPicture Then CheckIsPic = True
End If
End Function
Sub CenterOnSlide(oShp As Shape)
Dim sngSlideWidth As Single
Dim sngSlideHeight As Single
sngSlideWidth = ActivePresentation.PageSetup.SlideWidth
sngSlideHeight = ActivePresentation.PageSetup.SlideHeight
oShp.Left = sngSlideWidth / 2 - oShp.Width / 2
oShp.Top = sngSlideHeight / 2 - oShp.Height / 2
End Sub
For Each osld In ActivePresentation.Slides
If osld.SlideIndex > 1 Then Exit Sub 'I don't know if I need this line
' If you leave that line in, your code will only touch the first slide in the presentation.
' If that's what you want, fine. Otherwise, delete it and the matching End If below.
For Each oshp In osld.Shapes
If CheckIsPic(oshp) = True Then 'Making sure that we're only working with images
' With ActiveWindow.Selection.ShapeRange 'The portion of code I need help with
' Instead:
With oshp
.Align (msoAlignCenters), msoTrue
End With
End If
Next oshp
Next osld
End Sub