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
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
With PowerPoint, I have created several templates made of groups of shapes that I would copy to create nice image galleries in a Word document.
My idea is to automate the following process:
select a shape
shape format > shape fill > picture > from a file
picture format > crop > fill
by a macro that would do:
select all shapes in the selected slide
chose a folder and select pictures
fill each shape with the pictures
crop all the pictures in the shapes to fill the shapes
I have a macro that fill a specific shape on a specific slide with an image thanks to the filedialog. Thanks to commandbars I can do the PictureFillCrop.
Sub FillPictureAndFillCrop()
Dim strFilePath As String
With Application.FileDialog(msoFileDialogFilePicker)
If .Show <> 0 Then
strFilePath = .SelectedItems(1)
With ActivePresentation.Slides(1).Shapes(1).Fill
.Visible = msoTrue
.UserPicture strFilePath
End With
ActivePresentation.Slides(1).Shapes(1).Select
CommandBars.ExecuteMso ("PictureFillCrop")
End If
End With
End Sub
I still need to extend this macro to all the shapes of the selected slide with each pictures I have selected.
I have a previous macro with which I can select multiple pictures and add one picture per newly created slide.
I would like to adapt it to the macro above.
Sub AddOneImagePerNewSlide()
Dim ImgI As Long, tmpDIAPO As Slide
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "Images", "*.png, *.gif; *.jpg; *.jpeg", 1
If .Show = -1 Then
For ImgI = 1 To .SelectedItems.Count
Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutBlank)
tmpDIAPO.Shapes.AddPicture FileName:=.SelectedItems.Item(ImgI), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, Top:=0, _
Width:=-1, Height:=-1
Next
End If
End With
End Sub
I think it would be a mix of the 2 above macro would work.
Is it doable?
Yes, it is doable.
With this macro you will not need to select the Shapes.
Sub ShapePictureFitCrop(Shape As Shape)
Dim Width As Double, Height As Double
With Shape
Width = .Width
Height = .Height
.ScaleWidth 1, msoFalse
.ScaleHeight 1, msoFalse
.PictureFormat.CropRight = .Width * Width / 100
.PictureFormat.CropBottom = .Height * Height / 100
End With
End Sub
#Clemleb
To loop through all the shapes on each slide, you'd do something like this:
Option Explicit
Sub EachShape()
Dim oSh As Shape
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' You might add code here to
' ensure that it's the right shape type
' For example, exclude shapes with text
If oSh.HasTextFrame And oSh.TextFrame.HasText Then
' Leave it alone
Else
Call DoSomethingWith(oSh)
End If
Next ' Shape
Next ' Slide
End Sub
Sub DoSomethingWith(oSh As Shape)
' you could call TinMan's example here
ShapePictureFitCrop (oSh)
' then do other things with the shape
End Sub
Sub ShapePictureFitCrop(Shape As Shape)
Dim Width As Double, Height As Double
With Shape
Width = .Width
Height = .Height
.ScaleWidth 1, msoFalse
.ScaleHeight 1, msoFalse
.PictureFormat.CropRight = .Width * Width / 100
.PictureFormat.CropBottom = .Height * Height / 100
End With
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