I have several images on a worksheet. I want to resize them all to the same size, but I can\'t seem to get it working quite right. I thought it would be like the code below, b
David's answer was just what I was looking for. I'll add one more thing that has helped me a lot in the past day or so. The script below takes all images on a sheet and organizes them in a fashion so that all are staked one below the another, none are overlapping, and all have a small space between them. This makes everything very organized and easy to follow.
Sub AutoSpace_Shapes_Vertical()
'Automatically space and align shapes
Dim shp As Shape
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Const dSPACE As Double = 20
'Set variables
lCnt = 1
ActiveSheet.Shapes.SelectAll
'Loop through selected shapes (charts, slicers, timelines, etc.)
For Each shp In Selection.ShapeRange
With shp
'If not first shape then move it below previous shape and align left.
If lCnt > 1 Then
.Top = dTop + dHeight + dSPACE
.Left = dLeft
End If
'Store properties of shape for use in moving next shape in the collection.
dTop = .Top
dLeft = .Left
dHeight = .Height
End With
'Add to shape counter
lCnt = lCnt + 1
Next shp
End Sub
I think you're only missing a minor thing. By default (when I test it) images inserted to the sheet have LockAspectRatio=True
.
You need to set this to False
, otherwise the changes may be unpredictable: if you step through the code using F8 you can observe that Width
changes, but then on the next line Height
reverts the width change from previous.
So, set this to false and the images should retain the specified width/height.
Option Explicit
Sub ChangeAllPics()
Dim s As Shape
Dim ws As Worksheet
Set ws = ActiveSheet
For Each s In ActiveSheet.Shapes
s.LockAspectRatio = msoFalse
s.Width = 500
s.Height = 200
Next s
End Sub