CODEWITHSUNDEEP
vbaexcel
ASH
ASH

Reputation: 20362

How to resize all images on a worksheet?

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, but this actually makes everything different sizes.

Sub ChangeAllPics()
Dim s As Shape
For Each s In ActiveSheet.Shapes
s.Select
    s.Width = 500
    s.Height = 200
Next s
End Sub

Upvotes: 1

Views: 4871

Answers (2)

ASH
ASH

Reputation: 20362

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

Upvotes: 0

David Zemens
David Zemens

Reputation: 53663

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

Upvotes: 5

Related Questions