Reduce Picture Size

[Dick Kusleika]

I get a Word document with several images in it. Some of the images are so
large that my printer runs out of memory when it reaches that page. I'd
like to identify large images and reduce their size.

I don't have control over creating the document, so I can't reduce the image
size before inserting.

Where I'm stuck is in identifying the object. The document as 52 Shapes and
20 InlineShapes. The large pictures are in the Shapes collection, but not
in the InlineShapes collection. InlineShapes has a ScaleHeight property
which looks very promissing.

I'm not too smart about pictures in Word. I think when I personally insert
a picture, it's an InlineShape. But the pictures I'm dealing with appear to
be different. It's like they're in their own little box. The box can be
moved around and the text moves out of it's way.

So I'm looking for something like

ThisDocument.Shapes("Picture 438").???.ScaleHeight

Thanks,

 

[macropod]

Hi Dick,

You can resize the selected shape using something like:

Sub Resize_Shape()
Dim SngScale As Single
SngScale = 0.75
If Selection.Type <> wdSelectionShape Then Exit Sub
With Selection.ShapeRange
.ScaleHeight SngScale, True
.ScaleWidth SngScale, True
End With

The above code resizes the selected shape to 75% of its original size.

 

[Dick Kusleika]

Hi Dick,

You can resize the selected shape using something like:

Sub Resize_Shape()
Dim SngScale As Single
SngScale = 0.75
If Selection.Type <> wdSelectionShape Then Exit Sub
With Selection.ShapeRange
.ScaleHeight SngScale, True
.ScaleWidth SngScale, True
End With

The above code resizes the selected shape to 75% of its original size.

Thanks macropod. Do you know how I can read the existing scaling rather
than change it?

Thanks,

 

[macropod]

Hi Dick,

Here's one way:

Sub GetShapeScale()
Dim SngHScale As Single, SngVScale As Single, Height As Single, Width As Single
If Selection.Type <> wdSelectionShape Then Exit Sub
Application.ScreenUpdating = False
With Selection.ShapeRange
Height = .Height
Width = .Width
.ScaleHeight 1, True
.ScaleWidth 1, True
SngHScale = Height / .Height
SngVScale = Width / .Width
MsgBox "Original Height: " & .Height & " points" _
& vbCr & "Original Width: " & .Width & " points" _
& vbCr & "Original Vertical Scale: " & SngHScale _
& vbCr & "Original Horizontal Scale: " & SngVScale
.ScaleHeight SngHScale, True
.ScaleWidth SngVScale, True
End With
Application.ScreenUpdating = True
End Sub