PICTURES : Resize , Position and put on new slides

[christian.as]

The problem :

I copy 1 to 50 jpg pictures to slide number 3 in the Power Point Presentation.

I want each picture from slide number 3 to be placed on a new slide and then positioned and resized on the slide.

The Macro should end where there is no pictures left on slide number 3 to move.

I work in centimeters

Is this possible ?

[John Wilson]

It is possible but some more details would help.

This would give you a start to work with:


Sub PicInsert()
Dim L As Long
Dim osld As Slide
For L = ActivePresentation.Slides(3).Shapes.Count To 1 Step -1
If isPic(ActivePresentation.Slides(3).Shapes(L)) Then
ActivePresentation.Slides(3).Shapes(L).Cut
Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
With osld.Shapes.Paste
'change the values to what you need
.Left = cm2Points(1)
.Width = cm2Points(10)
.Top = cm2Points(1)
End With
End If
Next L
End Sub


Function isPic(oshp As Shape) As Boolean
If oshp.Type = msoPicture Then
isPic = True
Exit Function
End If
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.ContainedType = msoPicture Then
isPic = True
Exit Function
End If
End If
End Function


Function cm2Points(inVal As Single)
cm2Points = inVal * 28.346
End Function

[christian.as]

Hi John

Thank you for such a quick feedback !

The Macro is doing the cut and past correctly.

Maybe you could help me where in the Macro I need to change the parameters ?

The size of the picture should be 15cm in height but keeping the picture scaling in width
The picture should be placed 3cm up from the bottom of the slide and centered.18196

See below


Thanks again !

[John Wilson]

Try

Sub PicInsert()
Dim L As Long
Dim osld As Slide
For L = ActivePresentation.Slides(3).Shapes.Count To 1 Step -1
If isPic(ActivePresentation.Slides(3).Shapes(L)) Then
ActivePresentation.Slides(3).Shapes(L).Cut
Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
With osld.Shapes.Paste
'change the values to what you need
.Height = cm2Points(15)
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = ActivePresentation.PageSetup.SlideHeight - cm2Points(18) 'note this is 15 +3
End With
End If
Next L
End Sub


Function isPic(oshp As Shape) As Boolean
If oshp.Type = msoPicture Then
isPic = True
Exit Function
End If
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.ContainedType = msoPicture Then
isPic = True
Exit Function
End If
End If
End Function


Function cm2Points(inVal As Single)
cm2Points = inVal * 28.346
End Function