VBA to re-size all (inline) images in a document?

[Ted Kerin]

I need to regularly copy/paste records from a proprietary net-based program,
into Word. The records include a mix of text and, at irregular intervals,
images of various sizes and shapes.

The problem is that, although the images are inline, many of them are
oversized, extending well beyond the margins. (I realize this may sound
unusual, with inline images. It might have something to do with the way
that, as I understand it, the original program downloads the images from a
different server than the source of the text, then inserts them into the
records, inline, as links, which then appear as images in the program -- and
in Word -- if the user is online. I can email an example, if this would
help. I usually break the links to save the images into the Word file, so
that the documents can be emailed with images included, but this does not
fix the oversized-image problem.)

I know that there are non-VBA methods to re-size each image. But sometimes
there are hundreds of images in each set of records, so that manual
re-sizing obviously becomes tedious, time-consuming and frustrating.

Is it possible (especially for a VBA-dummy like me) to devise a VBA that
would automatically re-size all of the images in a document, all to a
selected width? (or, to shrink just the oversized images to a selected
maximum width)?

Thanks for any advice.

 

[Helmut Weber]

Hi Ted,


no problem, except for distorsion(!!!).

Sub Test504()
Dim oInl As InlineShape
For Each oInl In ActiveDocument.InlineShapes
oInl.Height = 100
oInl.Width = 100
Next
End Sub

or

Sub Test504()
Dim oInl As InlineShape
For Each oInl In ActiveDocument.InlineShapes
oInl.Height = oInl.Height / 10
oInl.Width = oInl.Height / 10
Next
End Sub

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Ted Kerin]

Hi Helmut,

Thank you for your help.

Unfortunately, I am, a true beginner! I have used Word for years, but I have
never created a Word macro or used a VBA editor. Can you please refer me to
some basic instructions on how to use the commands that you kindly posted?

 

[Helmut Weber]

Hi Ted,

see:

http://www.gmayor.com/installing_macro.htm

http://word.mvps.org/FAQs/MacrosVBA/VBABasicsIn15Mins.htm

http://word.mvps.org/FAQs/MacrosVBA/UsingRecorder.htm

http://word.mvps.org/faqs/macrosvba/ModifyRecordedMacro.htm

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Ted Kerin]

Thank you, Helmut. I appreciate you giving me the chance to learn a little
bit about this.

I was able to create macros from what you gave me, but unfortunately the
distortion is a big problem. I was hoping there was a way to make a macro
that would maintain each image's original proportions or shape, while
re-setting the width to a fixed (or a maximum) size, such as 6 inches. The
problem is that the images, as I receive them, are all different sizes and
shapes.

Thanks again.

 

[Helmut Weber]

Hi Ted,

it needs a bit af mathematics to do that:

Sub Test504y()
Dim oInl As InlineShape
Dim factor As Single
For Each oInl In ActiveDocument.InlineShapes
factor = InchesToPoints(6) / oInl.Width
oInl.Height = InchesToPoints(6)
oInl.Width = oInl.Width * factor
Next
End Sub

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Helmut Weber]

....
or the other way round:

Sub Test504z()
Dim oInl As InlineShape
Dim factor As Single
For Each oInl In ActiveDocument.InlineShapes
factor = InchesToPoints(6) / oInl.Height
oInl.Width = InchesToPoints(6)
oInl.Height = oInl.Height * factor
Next
End Sub

HTH

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

 

[Ted Kerin]

Sorry, Helmut, both of these also distort the images.

Is there a way to maintain the original aspect ratio, and set the exact (or
the maximum) width, while letting the height be adjusted automatically to
maintain the aspect ratio? The original images are never too tall for the
page, but they are often too wide.

Thanks...

 

[Doug Robbins - Word MVP]

Here's a bit of code from an application which in part, inserts a logo into
the cell of a table and then adjusts the size, while maintaining the aspect
ratio so that it fits in the cell.

'Insert Logo on Title Page
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.Delete
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes.AddPicture Filename:=txtLargeLogoPath
'Adjust size of logo to match avalable space
oheight =
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes(1).Height
owidth =
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes(1).Width
If oheight < InchesToPoints(2) Then
With
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes(1)
.Height = InchesToPoints(2)
.Width = owidth * InchesToPoints(2) / oheight
End With
End If
oheight =
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes(1).Height
owidth =
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes(1).Width
If owidth > InchesToPoints(2.85) Then
With
myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1,
1).Range.InlineShapes(1)
.Width = InchesToPoints(2.85)
.Height = oheight * InchesToPoints(2.85) / owidth
End With
End If


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Helmut Weber]

Hi Ted,

to the best of my kowledge,

Sub Test504z()
Dim oInl As InlineShape
Dim factor As Single
Dim RatioStart As Single
Dim RatioEnd As Single
For Each oInl In ActiveDocument.InlineShapes
RatioStart = oInl.Height / oInl.Width
factor = InchesToPoints(6) / oInl.Height
oInl.Width = InchesToPoints(6)
oInl.Height = oInl.Height * factor
RatioEnd = oInl.Height / oInl.Width
If RatioStart <> RatioEnd Then
MsgBox "no"
Else
MsgBox "yes"
End If
Next
End Sub

I get some no's for the first run of the macro,
maybe due to rounding issues,
but then never after.

Maybe somebody else knows better.


--
Gruß

Helmut Weber, MVP WordVBA

"red.sys" & chr$(64) & "t-online.de"
Win XP, Office 2003 (US-Versions)

 

[Ted Kerin]

Thanks, Helmut. Unfortunately this is still changing the aspect ratio. I
appreciate your ideas and your time anyway.

 

[Ted Kerin]

I appreciate your response, Doug, but I'm not able to adapt this as needed.

 

[Ted Kerin]

It just occurred to me that if I describe how I do it manually, this might
suggest to a VBA expert how to do the same thing with a Macro:

1) Click on the first oversized image
2) Format | Picture
3) On the Size tab, Delete the entry in the Height column, and LEAVE IT
BLANK. In the Width column, type 6.
Leave everything else on the Size tab at the defaults: Height and width
scales 100%, "Lock aspect ratio" and "Relative to original picture size"
selected.
4) Click OK.
5) Scroll down to the next oversized image, click on it, then hit F4
(Repeat). Continue these steps until all oversized images are shrunk.

Note, when I OK to resize the first image, I see that the Height field on
the Size tab gets populated at the last moment. Nevertheless, I find that
this Height is not part of what gets repeated, for the other images, when I
hit F4. Instead, F4 just repeats the Width setting, adjusting the height to
fit the aspect ratio.

This works fine, but is still much more time-consuming, for documents with
many images, than a Macro would be.

I hope this helps. Thanks very much.

 

[skatonni]

To retain the original proportions try this:


Code
-------------------
Sub ResizeWidth()
Dim oInl As InlineShape
For Each oInl In ActiveDocument.InlineShapes
If oInl.Width > InchesToPoints(6) Then
oInl.Width = InchesToPoints(6)
oInl.ScaleHeight = oInl.ScaleWidth
End If
Next
End Su

 

[Ted Kerin]

Hooray! This works perfectly! Thank you!!!

And thanks, also, to Helmut and to Doug, for your thoughts, your time, your
training and your input on solving this puzzle.