Help. Recording a Macro to resize maintaining aspect ratio

[Simon]

Hi there,

I have a document with lots of images that are too big. I am trying to
resize them all to 11cm wide and maintain the aspect ratio for the height.
I recorded a basic macro but the height is equal to whatever measurement was
in there when I recorded.

Any way around this please!!!

Thanks

Simon

 

[Brian]

This code was given to me in answer to my question on the same subject by
Stefan

Sub PictSize()
Dim HieghtSize As Integer
Dim oIshp As InlineShape
Dim oshp As Shape
HeightSize = InputBox("Enter height ", "Resize Picture", 11)
For Each oIshp In ActiveDocument.InlineShapes
With oIshp
.LockAspectRatio = msoTrue
'Here's the modified line of code:
.Height = CentimetersToPoints(HeightSize)
End With
Next oIshp
End Sub

Hope it helps

 

[DeanH]

Hello Simon and Brian.
Unfortuantely this macro is set for height and does not maintain ratio. I am
sure with minor tinkering this will work.
In the mean time I have the below macro which I got from someone on this
forum sometime ago (cannot remember for the moment) and this does work.

TIP: This macro will only change images that are InLineWithText and not
floating. If the images are floating (ie not set with the InLineWithText) the
you can
use the Select Multiple Objects (the icon is found on the Drawing Toolbar
under Customize).
Beware this may select objects you don't want to change, so tread carefully
- maybe work on a copy of the document.

If the Images are InLineWith then the following macro will change all in one
click.

Sub ResizePictureWidth()
' Macro to Resize ALL pictures in the document

Dim inshpPower As InlineShape
Dim sngOldWidth As Single
Const sngNewWidth As Single = 13.5
With ActiveDocument
If .InlineShapes.Count > 0 Then
For Each inshpPower In .InlineShapes
With inshpPower
sngOldWidth = .Width
.Width = CentimetersToPoints(sngNewWidth)
.Height = CentimetersToPoints(((.Height * sngNewWidth) /
sngOldWidth))
End With
Next
Else
MsgBox "There are no shapes in this document.", _
vbExclamation, "Cancelled"
End If
End With
End Sub

This macro is set for 13.5cm (my text margin width), so you may need to
change this for your needs.
See http://word.mvps.org/FAQs/MacrosVBA/CreateAMacro.htm for help with macros.
You don't say want Word version you are using, the above is mainly for 2003
and prior but will indicate were to go with 2007.
Hope this helps
DeanH

 

[Simon]

Thank you both for your work... much appreciated.

 

[Simon]

Just as a side note, will this run on all the pictures in the document or
selected images? I ask because some are smaller than 11cm wide and I don't
want to resize those.

Many many thanks

Simon