Excel图片调整大小

Sub 图片调整合适大小()
'    Debug.Print ActiveWorkbook.Name
    图片显示比例 = 0.9    '1为顶满单元格
    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()    'Redim preserve arr(i)
    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

            '.Name = .Name & Rnd(1000)
            '--------------------------------------------------------------
            wt = shp.TopLeftCell.MergeArea.Width  '单元格区域宽度；
            ht = shp.TopLeftCell.MergeArea.Height    '单元格区域高度

            bl = .Width / .Height
            If wt / ht < bl Then
                .Width = wt * 图片显示比例  ' sh0.Cells(st_mid2, 1).Width
                .Height = .Width / bl
                .Left = shp.TopLeftCell.MergeArea.Left + (wt - .Width) / 2  ' + 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