Excel图片调整大小

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