I need to create a PowerPoint with 200-300 slides with a picture and the person's name on each slide. I turned to PowerPoint and VBA to get the job done. I've got the name issue handled. I've got the importing of images working with the Photo Album. It places the images large and in the center. I turned to using a Macro (see below) to move/resize the image. It only works for one slide. I've searched all over on how to loop so that it will do this for all slides but I can't figure it out. I'm new to VBA so I don't know where to begin. Thank you in advance for any advice or help!
Sub ResizeImages()
With ActiveWindow.Selection.ShapeRange
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End Sub
try this:
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
Next
Next
End Sub
Here's the full code so you don't have to pull your hair out if your a noob like me
Sub pictureformatloop()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoPicture Then
With shp
.Height = 300.3
.Width = 639.7
.Left = 1125.7
.Top = 270.4
End With
End If
Next
Next
End Sub
Related
I need help for this case and could not find an answer anywhere on the internet.
Basically, I have a powerpoint slide with hundreds of slides, each containing a picture. I would like this picture to be resized and moved to a specific location.
The code i made resized every picture on each slide.
'''
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
Next sld
Next shp
End Sub
'''
I thought that by specifying the image name to resize, i could esssentially resize only that picture since all of them have the name "Content Placeholder 2" and ended up with this code:
'''
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Name = ("Content Placeholder 2") Then
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End If
Next sld
Next shp
End Sub
'''
I'm guessing the code doesnt run because 'Content Placeholder 2' doesn't exist on the first few slides. But when i add On Error Resume Next, everything is resized. Thank you for any help or advice, greatly appreciated.
"when i add On Error Resume Next, everything is resized" Are you telling use this solves the problem with the photo, or do you mean that all objects are resized, not just the photo? If the latter, you'll need some other identifier for the shape to be resized, just as its starting position. This code checks that the shape top is between 100 and 400, then resizes the shape if it meets those conditions:
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Top > 100 And shp.Top < 400 Then
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End If
Next sld
Next shp
End Sub
Or, if each slide only has 1 content placeholder, this checks that the first part of the name is correct, then resizes:
Sub resizeImage()
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If Left(shp.Name, 19) = "Content Placeholder" Then
With shp
.Height = 400
.Width = 300
.Left = 45
.Top = 45
End With
End If
Next sld
Next shp
End Sub
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 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
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