For not-too-interested readers: Use the third code snippet.
It’s time for a new post on VBA! Somebody at work is creating a whole lot of training material in Word. Great. Fast forward a couple months, and all of a sudden it’s my job to fix these up. They have all kinds of formatting inconsistencies, and many of the screenshots were resized without preserving their aspect ratios.
I thought, great, I’ll just write some VBA that fixes the screenshots. I quickly came up with something like the following:
Sub resize_all_images_to_page_width()
For Each inline_shape In ThisDocument.InlineShapes
inline_shape.LockAspectRatio = msoFalse
inline_shape.ScaleWidth = 100
inline_shape.ScaleHeight = 100
percent = doc.PageSetup.TextColumns.Width / inline_shape.Width
inline_shape.ScaleWidth = percent * 100
inline_shape.ScaleHeight = percent * 100
Next
End Sub
This would in theory scale every image to fit to the page’s width.
And it worked. For almost all of the images. For some, it did something incomprehensible (Word 2010) and turned images into a very long and extremely thin strip of pixels. I tried various things (including .Reset) and did some googling, but couldn’t find a better way to fix the images. What I really wanted was to find out an image’s original width and height, just the way it’s displayed in the Format Picture dialog in the Size tab, but there’s no way to access those values.
So to get an image’s original size, I decided to create a new temporary document, copy and paste the image there, set the .ScaleWidth and .ScaleHeight options to 100, and then look at its .Width and .Height properties. Yay, there we go!
I also decided I don’t want to scale images beyond 100% and added some extra logic to handle that. Here’s the result:
Sub resize_all_images_up_to_page_width()
Set current_doc = ThisDocument
Set new_doc = Documents.Add(DocumentType:=wdNewBlankDocument)
current_doc.Activate
For Each ishape In current_doc.InlineShapes
' ishape.Copy ' doesn't work
ishape.Select ' <work-around>
Selection.Copy ' </work-around>
new_doc.Content.PasteAndFormat (wdPasteDefault)
Set new_ishape = new_doc.InlineShapes(1)
new_ishape.LockAspectRatio = msoFalse
new_ishape.ScaleWidth = 100
new_ishape.ScaleHeight = 100
ishape.LockAspectRatio = msoFalse
If (new_ishape.Width > current_doc.PageSetup.TextColumns.Width) Then
ishape.Width = current_doc.PageSetup.TextColumns.Width
ishape.Height = (current_doc.PageSetup.TextColumns.Width / new_ishape.Width) * new_ishape.Height
Else
ishape.Width = new_ishape.Width
ishape.Height = new_ishape.Height
End If
new_ishape.Delete
ishape.LockAspectRatio = msoTrue
Next
End Sub
And finally, we’d like to make sure images don’t get longer than the length of a page:
Sub resize_all_images_up_to_page_width()
Set current_doc = ThisDocument
Set new_doc = Documents.Add(DocumentType:=wdNewBlankDocument)
page_width = current_doc.PageSetup.TextColumns.Width
page_height = current_doc.PageSetup.PageHeight - current_doc.PageSetup.TopMargin - current_doc.PageSetup.BottomMargin
current_doc.Activate
For Each ishape In current_doc.InlineShapes
' ishape.Copy ' doesn't work
ishape.Select ' <work-around>
Selection.Copy ' </work-around>
new_doc.Content.PasteAndFormat (wdPasteDefault)
Set new_ishape = new_doc.InlineShapes(1)
new_ishape.LockAspectRatio = msoFalse
new_ishape.ScaleWidth = 100
new_ishape.ScaleHeight = 100
ishape.LockAspectRatio = msoFalse
If (new_ishape.Width > page_width) Then
If ((page_width / new_ishape.Width) * new_ishape.Height > page_height) Then
ishape.Width = page_height / new_ishape.Height * page_width
ishape.Height = page_height
Else
ishape.Width = page_width
ishape.Height = (page_width / new_ishape.Width) * new_ishape.Height
End If
ElseIf (new_ishape.Height > page_height) Then ' going to be shrinking both height and width, and width is okay already, so it'll be even okayer
ishape.Width = page_height / new_ishape.Height * new_ishape.Width
ishape.Height = page_height
Else
ishape.Width = new_ishape.Width
ishape.Height = new_ishape.Height
End If
new_ishape.Delete
ishape.LockAspectRatio = msoTrue
Next
End Sub
Hope this helps! If you have any questions, feel free to leave a comment.
