使用Excel VBA调整大小并更改多张图片的格式

Question

I have an excel worksheet with a lot of pictures with various sizes and formats. I want to use excel VBA to loop through all the pictures in the worksheet, and set each picture to the same width (214) and change the picture type to a JPEG after resizing (to keep the file size down). My pictures are located in various cells, and I don't want the picture locations to change (ie stay in the same cell). I'm new to VBA and tried the following - but it doesn't work. The debugger stops at the line where I'm trying to cut the picture.

Sub Macro6()

Dim p As Object

Dim iCnt As Integer

    For Each p In ActiveSheet.Shapes
        p.Width = 217.44
        p.Cut
        p.PasteSpecial Format:="Picture (JPEG)", Link:=False
        iCnt = iCnt + 1
    Next p
End Sub

Answer 1

It's not the cutting part that Excel doesn't like--it's the pasting part. Paste and PasteSpecial are methods you call with a worksheet object (where you're pasting to) instead of the image (the thing you're pasting). I don't know if you want to just shrink the width and hold the height constant or if you want to scale both dimensions evenly. If you want to scale both evenly, try this:

Sub Macro6()
Dim p As Object

Dim iCnt As Integer
Dim s As Double
Dim r As Range

For Each p In ActiveSheet.Shapes
    s = 214 / p.Width
    Set r = p.TopLeftCell
    p.Width = 214
    p.Height = p.Height * s
    p.Cut
    r.Select
    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False
    Application.CutCopyMode = False
    iCnt = iCnt + 1
Next p
End Sub

If you're just trying to shrink the width and leave the height the same, try this:

Sub Macro6()
Dim p As Object

Dim iCnt As Integer
Dim r As Range

For Each p In ActiveSheet.Shapes
    Set r = p.TopLeftCell
    p.Width = 214
    p.Cut
    r.Select
    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False
    Application.CutCopyMode = False
    iCnt = iCnt + 1
Next p
End Sub

The locations of your pictures should stay exactly the same if they were originally right at the corner of a cell. Otherwise, this will align the top left corner of the image to the nearest cell corner. The Application.CutCopyMode = False is good practice after pasting. It tells Excel to wipe the clipboard and go back to normal operation instead of waiting for you to paste again. Hope this helps.

Answer 2

Thanks for answering my question! Here's the code I ended up using based on your suggestions. The program took several minutes to run (had over 5000 pictures in the file - yikes!). However, it was worth the wait, because it shrunk the file size in half.

Sub all_pics_to_jpeg()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Dim mypic As Shape

Dim picleft As Double

Dim pictop As Double

For Each mypic In ActiveSheet.Shapes

  mypic.LockAspectRatio = msoTrue

  If mypic.Width > mypic.Height Then
    mypic.Width = 217.44
  Else: mypic.Height = 157.68
  End If

  picleft = mypic.Left
  pictop = mypic.Top

  With mypic
      .Cut
      ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, _
        DisplayAsIcon:=False
      Application.CutCopyMode = False
      Selection.Left = picleft
      Selection.Top = pictop
  End With

Next mypic

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub