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