Word VBA Macro Needed to Crop & Resize Pictures

[Alex Cheng]

Hi Everyone, first post here so please bear with me if I'm not posting in the right place.

I'm a real estate appraiser and I often need to insert various digital photos of property within my reports that are written in MS Word. I'm currently using a macro to shrink down the images I've inserted into my Word documents so that they fit into the width of the document. The macro I've been using looks like this:


Public Sub ResizePictures()
Dim oDoc As Document, oShape As InlineShape
Set oDoc = Application.ActiveDocument

For Each oShape In oDoc.InlineShapes
oShape.Width = 216
Next oShape

Set oDoc = Nothing
End Sub

This macro works great when the orginal images are of the same size and aspect ratio, as they would be coming from a digital camera, however, I now need to screen grab images (using the built in windows Snipping Tool) from online sources like Google Maps and because these screen grab images now have variable sizes and aspect ratios, this macro cannot reduce the photos in a consistent manner, and as a result, the shrunken images end up being different sizes in the Word document. I think this has to do with the locking aspect ratio of the images.

I am hoping that someone could help me modify this macro to account for variable image sizes and aspect ratios. I'm thinking the easiest method might be to crop the screen grab images so that they are in a standard aspect ratio (something like 3:2), and then shrinking the images down as I have been. Naturally the cropping must be minimal so that the image doesn't lose its integrity, but still get to a constant aspect ratio before they are shrunk down. Perhaps there is a better way to do this, but not knowing much about editing images, I'm certainly open to any suggestions that may produce the desired results.

I hope I've provided enough information to at least get the ball rolling, but please let me know if there are any details missing. I thank you all in advance for your help.

[macropod]

Before:

oShape.Width = 216
insert:

oShape.LockAspectRatio = True

[macropod]

Cross-posted at: http://www.msofficeforums.com/word-vba/41041-word-vba-macro-needed-crop-resize-pictures.html
Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3

[Alex Cheng]

My apologies. I didn't know that cross-posting was prohibited.

[Alex Cheng]

Before:

oShape.Width = 216
insert:

oShape.LockAspectRatio = True



I tried your suggestion and it didn't make a difference in the results. I also tried setting LockAspectRatio = False and that made the results worse. I wonder if the LockAspectRatio parameter is true by default.

Nevertheless, I think the issue is that since I'm doing a drag & drop screen grab, the size and aspect ratio of each image will be a little different. It doesn't appear that a difference in size makes that big of a difference in the result, but a difference in aspect ratio does.

[Alex Cheng]

Update: Someone on another forum suggested that I try Snagit, and it does exactly what I need, which is to capture the image in a fixed size and aspect ratio.

[james_martin]

I had to do this, as embedded images from customer mobiles
are often embedded and larger than A4 when imported to docx
via a https://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/ macro.

It forces every embedded image within the A4 margins.



Sub ResizePicturesIF()
'Macro S
Dim oDoc As Document, oShape As InlineShape
Set oDoc = Application.ActiveDocument
For Each oShape In oDoc.InlineShapes
If oShape.Width > 510 Then
oShape.LockAspectRatio = True
oShape.Width = 510
End If
If oShape.Height > 660 Then
oShape.LockAspectRatio = True
oShape.Height = 660
End If
Next
Set oDoc = Nothing
End Sub