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
Related
Is there a way to align the text from right to left (it's Arabic) on all slides in a PowerPoint Presentation with a macro ? (I'm using O365).
In a Microsoft example I found this :
Application.ActivePresentation.Slides(1).Shapes(2) _
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
But i think that this example aligns the paragraphs of form 2 on slide 1 of the active presentation to the left.
So i don't know how to do it with all the shapes/slides types.
The professional coders may improve it, but I think this one should help you. You just have to select all slides before you click it, if you want the entire presentation to be done in one move. I think it is better than any entire-presentation-solution, because it gives you the opportunity to choose.
Option Explicit
Sub AlignAllTextLeft()
Dim osld As Slide
Dim oshp As Shape
Dim notesshp As Shape
Dim i As Long
Dim j As Long
Dim x As Long
On Error GoTo ErMsg
If MsgBox("You are going to change the text alignment of all text on all selected slides to left" & vbCrLf & "Continue?", vbYesNo) <> vbYes Then Exit Sub
For Each osld In ActiveWindow.Selection.SlideRange
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
oshp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
End If
If oshp.HasTable Then
For i = 1 To oshp.Table.Rows.Count
For j = 1 To oshp.Table.Columns.Count
oshp.Table.Rows.Item(i).Cells(j).Shape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
Next j
Next i
End If
Next oshp
For Each notesshp In osld.NotesPage.Shapes
If notesshp.HasTextFrame Then
notesshp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
End If
Next notesshp
Next osld
For Each osld In ActiveWindow.Selection.SlideRange
For Each oshp In osld.Shapes
With oshp
Select Case .Type
Case Is = msoGroup
For x = 1 To .GroupItems.Count
If .GroupItems(x).HasTextFrame Then
oshp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
End If
Next x
End Select
End With
Next oshp
Next
Exit Sub
ErMsg:
MsgBox "Please do not place the cursor between two slides"
End Sub
I use PowerPoint in my lectures and print a subset of the slides for my students (to allow them to fill in blanks before I show my answers). Currently, I put a light blue circle at the bottom left of slides that I want to hide while printing (but not while lecturing). I then manually hide slides when it is time to print them, then unhide all of the slides before lecturing. Is there any way to automate this process? I use Office 365 on both PCs and Macs.
This will get you started, save this as pptm then save a copy as addin:
ChangeAnswersSlideState - changes activeslide to be an Answer Slide or not
PrintStudentHandout - Hide Answer slides and then print, then unhide
Option Explicit
Private Const ANS_ID As String = "ANS"
Sub PrintStudentHandout()
ChangeAnswersSlideVisible
With ActivePresentation
.PrintOptions.ActivePrinter = "Microsoft XPS Document Writer"
.PrintOut
End With
ChangeAnswersSlideVisible msoFalse
End Sub
Private Sub ChangeAnswersSlideVisible(Optional Hide As MsoTriState = msoTrue)
Dim oSlide As Slide, oShp As Shape
For Each oSlide In ActivePresentation.Slides
For Each oShp In oSlide.Shapes
If IsAnswersShape(oShp) Then
oSlide.SlideShowTransition.Hidden = Hide
Exit For
End If
Next oShp
Next oSlide
End Sub
Sub ChangeAnswersSlideState()
Dim oShp As Shape, bChanged As Boolean
bChanged = False
For Each oShp In Application.ActiveWindow.View.Slide.Shapes
If IsAnswersShape(oShp) Then
oShp.Delete
bChanged = True
End If
Next oShp
If Not bChanged Then MakeAnswersSlide
End Sub
Private Sub MakeAnswersSlide(Optional ByRef AnswerSlide As Slide = Nothing)
If AnswerSlide Is Nothing Then Set AnswerSlide = Application.ActiveWindow.View.Slide
With AnswerSlide.Shapes.AddShape(msoShapeOval, -80, 460, 72, 72)
.TextFrame.TextRange.Text = ANS_ID
End With
End Sub
Private Function IsAnswersShape(ByRef CheckShape As Shape) As Boolean
Dim bIsAnAnswerShape As Boolean
bIsAnAnswerShape = False
With CheckShape
If .AutoShapeType = msoShapeOval Then
If .HasTextFrame Then
If .TextFrame.TextRange.Text = ANS_ID Then
bIsAnAnswerShape = True
End If
End If
End If
End With
IsAnswersShape = bIsAnAnswerShape
End Function
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
I have a macros that is unfortunately skipping all grouped shapes in PowerPoint where the text requires to be normalized (hard returns swapped with spacemarks). Now, I wrote a 'prepping' script that should find all shapes with text and ungroup those. For some reason it is not working. This should be so simple, yet I cannot get it to work. Please help!
Sub Ungroupallshapes()
Dim osld As Slide
Dim oshp As Shape
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.Type = msoGroup Then
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then oshp.Ungroup
End If
End If
Next oshp
Next osld
End Sub
Thank you!
I know this is an old post, but I needed a function to ungroup every group in a PowerPoint regardless of issues with animations as mentioned above. I used the following to continue looping through the slide objects while there was a group detected.Sub
Sub Shapes_UnGroup_All()
Dim sld As Slide
Dim shp As Shape
Dim intCount As Integer
intCount = 0
Dim groupsExist As Boolean: groupsExist = True
If MsgBox("Are you sure you want To ungroup every level of grouping On every slide?", (vbYesNo + vbQuestion), "Ungroup Everything?") = vbYes Then
For Each sld In ActivePresentation.Slides ' iterate slides
Debug.Print "slide " & sld.SlideNumber
Do While (groupsExist = True)
groupsExist = False
For Each shp In sld.Shapes
If shp.Type = msoGroup Then
shp.Ungroup
intCount = intCount + 1
groupsExist = True
End If
Next shp
Loop
groupsExist = True
Next sld
End If
MsgBox "All Done " & intCount & " groups are now ungrouped."
End Sub
Groups don't have TextFrames, so you're testing for something that will never happen.
If oshp.Type = msoGroup then oshp.Ungroup
should do it for simple groupings. But ungrouping can have unwanted side effects (blows away any animation on the group shape, for example). And it's not usually necessary. Consider:
Sub ChangeTheText()
Dim oshp As Shape
Dim oSld As Slide
Dim x As Long
For Each oSld In ActivePresentation.Slides
For Each oshp In oSld.Shapes
If oshp.HasTextFrame Then
oshp.TextFrame.TextRange.Text = "Ha! Found you!"
Else
If oshp.Type = msoGroup Then
For x = 1 To oshp.GroupItems.Count
If oshp.GroupItems(x).HasTextFrame Then
oshp.GroupItems(x).TextFrame.TextRange.Text _
= "And you too, you slippery little devil!"
End If
Next
End If
End If
Next
Next
End Sub
That still leaves you with the possible problem of groups within groups (within groups (within groups)) etc. There are ways around that, but if it ain't broke, we don't need to fix it.
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