You can do this with the following VBA code. It counts the shapes in the document, checks their width against the available space on the page, and resizes if necessary.
Note that Word has two different collections for Shapes
and InlineShapes
, hence the two different For
loops. Also, it uses a series of If/ElseIf
statements to identify the page width based on standard paper sizes. Currently, the only options are letter size in either portrait or landscape, but you can add more ElseIfs
for any paper sizes you need.
Sub ResizePic()
' ResizePic Macro
' Resizes an image
Shapes = ActiveDocument.Shapes.Count
InLines = ActiveDocument.InlineShapes.Count
'Sets the variables to loop through all shapes in the document, one for shapes and one for inline shapes.
RightMar = ActiveDocument.PageSetup.RightMargin
LeftMar = ActiveDocument.PageSetup.LeftMargin
PaperType = ActiveDocument.PageSetup.PaperSize
PageLayout = ActiveDocument.PageSetup.Orientation
'Sets up variables for margin sizes, paper type, and page layout.
' This is used to find the usable width of the document, which is the max width for the picture.
If PaperType = wdPaperLetter And PageLayout = wdPortrait Then
WidthAvail = InchesToPoints(8.5) - (LeftMar + RightMar)
ElseIf PaperType = wdPaperLetter And PageLayout = wdLandscape Then
WidthAvail = InchesToPoints(11) - (LeftMar + RightMar)
End If
'Identifies the usable width of the document, based on margins and paper size.
For ShapeLoop = 1 To Shapes
MsgBox Prompt:="Shape " & ShapeLoop & " width: " & ActiveDocument.Shapes(ShapeLoop).Width
If ActiveDocument.Shapes(ShapeLoop).Width > WidthAvail Then
ActiveDocument.Shapes(ShapeLoop).Width = WidthAvail
End If
Next ShapeLoop
'Loops through all shapes in the document. Checks to see if they're too wide, and if they are, resizes them.
For InLineLoop = 1 To InLines
MsgBox Prompt:="Inline " & InLineLoop & " width: " & ActiveDocument.InlineShapes(InLineLoop).Width
If ActiveDocument.InlineShapes(InLineLoop).Width > WidthAvail Then
ActiveDocument.InlineShapes(InLineLoop).Width = WidthAvail
End If
Next InLineLoop
'Loops through all shapes in the document. Checks to see if they're too wide, and if they are, resizes them.
End Sub