I am interested in applying the following VBA code to all slides in my powerpoint presentation. The code below resizes my table to the exact specifications I need. Do you have any advice on how to make this apply throughout my presentation? Thanks in advance.
Sub ResizeAlign()
With ActiveWindow.Selection.ShapeRange
.Height = 216
.Width = 864
.Left = 48
.Top = 198
ActiveWindow.Selection.ShapeRange.ZOrder msoSendToBack
End With
End Sub
The following macro will loop through each slide within the active presentation. Then, for each slide, it will loop through each shape within the slide until it finds a table, and then it formats the table.
Option Explicit
Public Sub ResizeAlignPresentation()
Dim currentSlide As Slide
For Each currentSlide In ActivePresentation.Slides
ResizeAlignSlide currentSlide
Next
End Sub
Private Sub ResizeAlignSlide(ByVal target As Slide)
Dim currentShape As Shape
For Each currentShape In target.Shapes
If currentShape.Type = msoTable Then
ResizeAlignTable currentShape
Exit For
End If
Next
End Sub
Private Sub ResizeAlignTable(ByVal table As Shape)
With table
Debug.Assert .Type = msoTable 'if code breaks here, we have a bug!
.Height = 216
.Width = 864
.Left = 48
.Top = 198
.ZOrder msoSendToBack
End With
End Sub
I have upped the last answer with this code I created (in need). I needed to run through all SlideMasters, all slides, all textboxes and put them on top. So they will always be in front of pictures etc.
Sub SetInFront()
Dim m, s, t, ma, sl, te
Set ma = ActivePresentation.Designs
For Each m In ma
Set sl = m.SlideMaster.CustomLayouts
For Each s In sl
Set te = s.Shapes
For Each t In te
If t.HasTextFrame Then
t.ZOrder 0
End If
Next t
Next s
Next m
End Sub
Related
I'm learning to create small macros for powerpoint.
I would like to change the position of the slides within the notes page.
I created this small macro:
Sub Macro_resize ()
With ActiveWindow.Selection.ShapeRange
.Height = 450
.Width = 510
.Left = 30
.Top = 290
End With
End Sub
I would like to apply it to all the slides, how could I do it?
I'd recommend you to not work with Select. function. You'd better Dim your range (all slides) and refer to that range.
Sub macro_resize()
Dim sld As Object
Dim shp As Object
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
With shp.Range
.Height = 450
.Width = 510
.Left = 30
.Top = 290
End With
Next
Next
End Sub
I need assistance to adapt my code.
Column E has 30 images of varying sizes that I want to centre in the cells starting with E5.
The code below only centres the images in cell E5. How do I adapt it centre all the images in each individual cell?
Sub aTest()
CenterMe ActiveSheet.Shapes(1), Range("E5")
End Sub
Sub CenterMe(Shp As Shape, OverCells As Range)
With OverCells
Shp.Left = .Left + ((.Width - Shp.Width) / 2)
Shp.Top = .Top + ((.Height - Shp.Height) / 2)
End With
End Sub
Sub CENTER_SHAPES()
Application.ScreenUpdating = False
Dim MyShape As Shape
For Each MyShape In ActiveSheet.Shapes
If MyShape.Type = msoPicture Then CenterMe MyShape, Range(MyShape.TopLeftCell.Address(False, False))
Next MyShape
Set MyShape = Nothing
Application.ScreenUpdating = True
End Sub
This code will loop every shape (image type) on active worksheet, and it will initiate your sub for centering. Hope it helps!
UPDATED ANSWER: Added ScreenUpdating=False because OP said it takes around 7 minutes.
I have a lot of slides, each with a single word art. I wish to align the word art to the absolute centre of the slide. the code I have tried is:
Option Explicit
Sub format()
Dim sl As Slide
Dim ob As Object
For Each sl In ActivePresentation.Slides
For Each ob In sl.Shapes
With ob.TextFrame
' .TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
' .TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignMiddle
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
Next ob
Next sl
End Sub
Maybe it wil help.
Option Explicit
Sub format()
Dim sl As Slide
For Each sl In ActivePresentation.Slides
sl.Shapes.Range.Align msoAlignCenters, msoTrue
sl.Shapes.Range.Align msoAlignMiddles, msoTrue
Next sl
End Sub
I've a macro that I used with some ppt's in office 2007 to reduce the size of some links within the ppt to an excel file. Recently I've installed the Office 2013 and the macro crashed with the following error:
Shape.select: invalid request. To select a shape, its view must be active
Here is the code:
Sub reduce()
For Each curr_slide In ActivePresentation.Slides
curr_slide.Select
For Each oSh In curr_slide.Shapes
If oSh.Type = msoLinkedOLEObject Then
Set oSh = curr_slide.Shapes(3)
With oSh
'.LinkFormat.BreakLink
.Select
.LockAspectRatio = False
.Height = 14 * 28.33
.Width = 33.5 * 28.33
.Cut
Set oSh = curr_slide.Shapes.PasteSpecial(DataType:=ppPastePNG)
.Height = 10 * 28.33
.Width = 23 * 28.33
.Left = 1.2 * 28.33
.Top = 1.85 * 28.33
.ZOrder (msoSendToBack)
End With
End If
Next oSh
Next curr_slide
End Sub
I believe now, I've to activate each shape in every slide but I don't know how to do it.
The problem may simply be that you're in a view that doesn't permit selecting slides, so ... don't select slides. There's no need to:
Sub reduce()
For Each curr_slide In ActivePresentation.Slides
' you don't need to select the slide to work with it
'curr_slide.Select
For Each oSh In curr_slide.Shapes
If oSh.Type = msoLinkedOLEObject Then
' Is there something magical about the third shape?
' And you're messing up your loop by setting
' oSh to a different shape here.
'Set oSh = curr_slide.Shapes(3)
' Instead, do this:
With curr_slide.Shapes(3)
'.LinkFormat.BreakLink
.Select
.LockAspectRatio = False
.Height = 14 * 28.33
.Width = 33.5 * 28.33
.Cut
' And again, setting oSh to a different
' value within the loop is bad practice:
Dim PastedShape as Shape
Set oPastedShape = curr_slide.Shapes.PasteSpecial(DataType:=ppPastePNG)
' and this, if you want the following code
' to affect the pasted shape:
With oPastedShape
.Height = 10 * 28.33
.Width = 23 * 28.33
.Left = 1.2 * 28.33
.Top = 1.85 * 28.33
.ZOrder (msoSendToBack)
End with
End With
End If
Next oSh
Next curr_slide
End Sub
I've solved the problem, basically by defining my datatype with the associated ID number instead of indicating the traditional "ppPasteXPTO". I've also used the number of the Bitmap format file instead of the PNG since it allows me to reduce the size of the ppt but it's not so heavy in the image compression like the PNG is. Here is the final code:
Sub reduce()
Dim shp As Shape
Dim sld As Slide
'Loop Through Each Slide in ActivePresentation
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoLinkedOLEObject Then
shp.Cut
Dim oShp As ShapeRange
Set oShp = sld.Shapes.PasteSpecial(DataType:=1)
End If
Next shp
Next sld
End Sub
I am trying to reference shapes by index in PPT VBA. It is working but it is a hit and miss because I am cutting and pasting them to different slides so the indexes keep changing. Is there another way to reference shapes so I don't have to deal with the indexes? Here is an example of my code:
ActivePresentation.Slides(1).Shapes(3).Cut
ActivePresentation.Slides(2).Shapes.Paste
ActivePresentation.Slides(1).Shapes(4).Cut
ActivePresentation.Slides(2).Shapes.Paste
With ActivePresentation.Slides(1).Shapes(3)
.Height = 325
.Width = 325
.Left = 190
.Top = 90
End With
With ActivePresentation.Slides(1).Shapes(4)
.Height = 600
.Width = 600
.Left = 65
.Top = 360
End With
Tag the shape before cutting, then call a function to return the shape tagged with that value from the target slide after pasting:
With ActivePresentation.Slides(1).Shapes(3)
.Tags.Add "SomeName", "SomeValue"
' whatever name and value you like
.Cut
End With
' Then paste it onto another slide
' and to get a reference to it:
Dim oSh as shape
Set oSh = ShapeTaggedWith(oSl, "SomeName", "SomeValue")
If Not oSh is Nothing Then
End If
' etc
Function ShapeTaggedWith(oSl as Slide, sTagName as String sValue as String) as Shape
Dim oSh as Shape
For each oSh in oSl.Shapes
If oSh.Tags(sTagName) = sValue Then
Set ShapeTaggedWith = oSh
Exit Function
End If
Next
End Function