Excel图片调整大小

Sub 图片调整合适大小()

图片显示比例 = 0.9

Dim wb As Workbook, sh As Worksheet, ce As Range, shp As Shape

Dim dic As Object, re As Object, shel As Object, WS As Object, FSO As Object

Dim arr(), brr()

Set dic = CreateObject("scripting.dictionary")

Set wb = ActiveWorkbook

Set sh = wb.Sheets(1)

For Each shp In sh.Shapes

With shp

shp.Name = shp.Name & Round(Rnd() * 125, 1)

shp.Top = shp.Top + shp.Height / 2

shp.Left = shp.Left + shp.Width / 2

shp.Height = shp.Height / 8

shp.Width = shp.Width / 8

wt = shp.TopLeftCell.MergeArea.Width

ht = shp.TopLeftCell.MergeArea.Height

bl = .Width / .Height

If wt / ht < bl Then

.Width = wt * 图片显示比例

.Height = .Width / bl

.Left = shp.TopLeftCell.MergeArea.Left + (wt - .Width) / 2

.Top = shp.TopLeftCell.MergeArea.Top + (ht - .Height) / 2

Else

.Height = ht * 图片显示比例

.Width = .Height * bl

.Top = shp.TopLeftCell.MergeArea.Top + (ht - .Height) / 2

.Left = shp.TopLeftCell.MergeArea.Left + (wt - .Width) / 2

End If

End With

Next

End Sub