Thread: Code to resize images maintaining ratio

Hi there.

I once had a macro which was built for me, that resized the width of an image to 11cm whilst maintaining the ratio of the height.

I am not very experienced at all in coding my own Macros. I have tried recording one to achieve this but the image never resizes the height correctly, it always resizes to the measurement of the picture that I resized whilst recording the macro.


Work have chucked away my old computer and I have lost all my lovely Macros

Can anyone help?

from here
http://www.pcreview.co.uk/forums/thread-3732765.php
insert into a new module(alt +f11 to open editor,then insert/ module
paste the code in)

Code:

Sub ResizeAllImages()
' make all images (both inline and floating)
' 11 cm wide while preserving aspect ratio

Dim oShp As Shape
Dim oILShp As InlineShape

For Each oShp In ActiveDocument.Shapes
With oShp
.Height = AspectHt(.Width, .Height, _
CentimetersToPoints(11))
.Width = CentimetersToPoints(11)
End With
Next

For Each oILShp In ActiveDocument.InlineShapes
With oILShp
.Height = AspectHt(.Width, .Height, _
CentimetersToPoints(11))
.Width = CentimetersToPoints(11)
End With
Next
End Sub

Private Function AspectHt( _
origWd As Long, origHt As Long, _
newWd As Long) As Long
If origWd <> 0 Then
AspectHt = (CSng(origHt) / CSng(origWd)) * newWd
Else
AspectHt = 0
End If
End Function