如何调整工作表上所有图像的大小?

Question

我在工作表上有几个图像。 我想将它们全部调整为相同的大小，但我似乎无法让它正常工作。 我以为它会像下面的代码一样，但这实际上使所有大小都不同。

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

Answer 1

我认为你只是错过了一件小事。默认情况下(当我测试它时(插入到工作表的图像具有LockAspectRatio=True.

您需要将其设置为False，否则更改可能是不可预测的：如果使用F8单步执行代码，则可以观察到Width更改，但在下一行Height恢复与以前的宽度更改。

因此，将其设置为 false，图像应保留指定的宽度/高度。

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

Answer 2

大卫的答案正是我想要的。 我还要补充一件事，它在过去一天左右的时间里对我有很大帮助。 下面的脚本将所有图像放在一张纸上，并以一种方式组织它们，以便所有图像都一个接一个地质押，没有重叠，并且它们之间都有一个小空间。 这使得一切都非常有条理且易于遵循。

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