How to resize all images on a worksheet?

前端 未结 2 1700
孤独总比滥情好
孤独总比滥情好 2021-01-24 02:29

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

相关标签:
2条回答
  • 2021-01-24 02:37

    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
    
    0 讨论(0)
  • 2021-01-24 02:58

    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
    
    0 讨论(0)
提交回复
热议问题