Maximize a Shape without hiding the title area

[eduardodanon]

Hello, everybody!

I have the following code to maximize a shape to the slide area. The problem is that it is covering the title. How could i change it to not cover it?
I tried changing the line

.Top = 0.5 * (myPresentation.PageSetup.SlideHeight - .Height)
for the following

.Top = 0.4 * (myPresentation.PageSetup.SlideHeight - .Height)
but for some reason that i dont know, some ranges do not get copied this way


Set myPresentation = PowerPointApp.ActivePresentation
NewWidth = myPresentation.PageSetup.SlideWidth
NewHeight = myPresentation.PageSetup.SlideHeight
With shp
If .Width > NewWidth Then
.LockAspectRatio = msoTrue
.Width = NewWidth - 100
End If
If .Height > NewHeight Then
.LockAspectRatio = msoTrue
.Height = NewHeight - 100
End If


If 3 * .Width > 4 * .Height Then
.Width = myPresentation.PageSetup.SlideWidth
.Top = 0.5 * (myPresentation.PageSetup.SlideHeight - .Height)

Else
.Height = myPresentation.PageSetup.SlideHeight
.Left = 0.5 * (myPresentation.PageSetup.SlideWidth - .Width)
End If
End With

'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x

[John Wilson]

See if these help as pointers

The first fills the space completely the second as large as possible without changing aspect. You will of course need to change oshp to point at the correct shape


Sub resizer()Dim oshp As Shape
Dim osld As Slide
Dim maxTop As Single
Dim SH As Long
Dim SW As Long
SW = ActivePresentation.PageSetup.SlideWidth
SH = ActivePresentation.PageSetup.SlideHeight
Set osld = ActiveWindow.Selection.SlideRange(1)
Set oshp = ActivePresentation.Slides(1).Shapes("Rectangle 5")
If osld.Shapes.HasTitle Then
maxTop = osld.Shapes.Title.Top + osld.Shapes.Title.Height
oshp.Top = maxTop
oshp.Width = SW
oshp.Left = 0
oshp.Height = SH - maxTop
End If
End Sub


Sub resizer_retainAspect()
Dim oshp As Shape
Dim osld As Slide
Dim maxTop As Single
Dim SH As Long
Dim SW As Long
Dim aspectRatio As Single
SW = ActivePresentation.PageSetup.SlideWidth
SH = ActivePresentation.PageSetup.SlideHeight
Set osld = ActiveWindow.Selection.SlideRange(1)
Set oshp = ActivePresentation.Slides(1).Shapes("Rectangle 5")
If osld.Shapes.HasTitle Then
maxTop = osld.Shapes.Title.Top + osld.Shapes.Title.Height
aspectRatio = oshp.Width / oshp.Height
If aspectRatio <= 1 Then
oshp.Top = maxTop
oshp.Height = SH - maxTop
oshp.Width = oshp.Height * aspectRatio
oshp.Left = SW / 2 - oshp.Width / 2
Else
oshp.Top = maxTop
oshp.Width = SW
oshp.Left = 0
oshp.Height = oshp.Width / aspectRatio
End If
End If
End Sub

[John Wilson]

If you have questions please put them here not in a private message.

If Set osld = ActiveWindow.Selection.SlideRange(1) errors it can really only be because you don't have a slide selected.