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
