Resize and align

[AndyDDUK]

Hi
Can anyone supply me with the code for a macro that resizes my two images (which I have selected) and resizes them both to 30% of their actual size and then places one beside the other so that they are are touching and aligned at the top like this [][] ?

Many thanks

Andy

[JohnWilson]

You probably need to explain more clearly the end product but this should get you close.

Sub fixalign()
Dim oshp1 As Shape
Dim oshp2 As Shape
Set oshp1 = ActiveWindow.Selection.ShapeRange(1)
Set oshp2 = ActiveWindow.Selection.ShapeRange(2)
oshp1.Width = oshp1.Width * 0.3
oshp2.Width = oshp2.Width * 0.3
oshp1.Top = 100
oshp2.Top = 100
oshp1.Left = 100
oshp2.Left = 100 + oshp1.Width
'group to centre
ActiveWindow.Selection.ShapeRange.Group.Select
ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'ungroup again
ActiveWindow.Selection.ShapeRange.Ungroup
End Sub

[AndyDDUK]

Brilliant thanks for this, this is very helpful

If I want the centre of the (grouped) imaged to be 7cm from top of the sheet and 7cm from the left are you also able to help me with that??

Be great if you can

Many thanks

Andy

[JohnWilson]

Sub fixalign2()
Dim oshp1 As Shape
Dim oshp2 As Shape
If ActiveWindow.Selection.ShapeRange.Count <> 2 Then Exit Sub
Set oshp1 = ActiveWindow.Selection.ShapeRange(1)
Set oshp2 = ActiveWindow.Selection.ShapeRange(2)
oshp1.Width = oshp1.Width * 0.3
oshp2.Width = oshp2.Width * 0.3
oshp1.Top = cm2Points(7)
oshp2.Top = cm2Points(7)
oshp2.Left = oshp1.Left + oshp1.Width

'group
ActiveWindow.Selection.ShapeRange.Group.Select
ActiveWindow.Selection.ShapeRange.Left = cm2Points(7)

End Sub

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

[AndyDDUK]

Thanks again John
As my images start off being slightly different size, do you know how I can get them to centre to a fixed point, eg the fixed point being 7cm from top and 7cm from left?

Appreciate your help

Cheers

Andy

[JohnWilson]

Maybe just move the group left by half its width?? That is make this change:

'group
ActiveWindow.Selection.ShapeRange.Group.Select
ActiveWindow.Selection.ShapeRange.Left = cm2Points(7) - ActiveWindow.Selection.ShapeRange.Width / 2

[AndyDDUK]

Excellent, thanks again John
I've also added in 'ActiveWindow.Selection.ShapeRange.Top = cm2Points(7) - ActiveWindow.Selection.ShapeRange.Width / 2'

If you are willing to help on the last bit (?) that would be amazing

I've got to place the group images inside a box (actually there are four boxes on my pages - 2 at top left and right, 2 at bottom left and right)...as the original sizes of the images can vary slightly,. the pages on the template (or the images themselves) sometimes need to be resized which can take time (given the amount that needs to be done)

It would be better if PowerPoint could place an outline around the grouped image (as opposed to an outline around each individual image)...are you able to help with this one too?

Many thanks again

Andy

[JohnWilson]

That should probably be .Height/2??

To get the outline around the box you would need to Cut and paste special as a png then add the outline. I would do this before you position.

If you havent solved it by tomorrow i'll be back! (it's 5 pm here)

here's a start

Sub fixalign2()
Dim oshp1 As Shape
Dim oshp2 As Shape
If ActiveWindow.Selection.ShapeRange.Count <> 2 Then Exit Sub
Set oshp1 = ActiveWindow.Selection.ShapeRange(1)
Set oshp2 = ActiveWindow.Selection.ShapeRange(2)
oshp1.Width = oshp1.Width * 0.3
oshp2.Width = oshp2.Width * 0.3
oshp1.Top = cm2Points(7)
oshp2.Top = cm2Points(7)
oshp2.Left = oshp1.Left + oshp1.Width

ActiveWindow.Selection.ShapeRange.Cut
With ActivePresentation.Slides(1).Shapes.PasteSpecial(ppPastePNG)
.Left = cm2Points(7) - .Width / 2
.Top = cm2Points(7) - .Height / 2
.Line.Visible = True
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 3
End With

End Sub

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

[AndyDDUK]

Morning John, this works brilliantly thanks!

I've actually need 4 boxes on (most of) my slides

I've tried to amend code to .right and .bottom but macro is not happy, are you able to help with this too?

.Left = cm2Points(7) - .Width / 2
.Top = cm2Points(7) - .Height / 2

You've been a huge help thank you

Andy

[AndyDDUK]

Hi John, I think I've solved this simply changing the figures for .left and .right

Last bit I think...are you able to help me with code to add a text box below the grouped images so its Arial, 12, black text, centred and bold?

Many thanks again

Andy