使用 Excel VBA 调整多张图片的大小和格式

Resize and change the format of multiple pictures using Excel VBA

提问by James

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 (i.e. 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.

我有一个 excel 工作表，里面有很多不同大小和格式的图片。我想使用excel VBA循环遍历工作表中的所有图片，并将每张图片设置为相同的宽度（214）并在调整大小后将图片类型更改为JPEG（以保持文件大小减小）。我的图片位于不同的单元格中，我不希望图片位置发生变化（即留在同一个单元格中）。我是 VBA 新手并尝试了以下操作 - 但它不起作用。调试器停在我试图剪切图片的那一行。

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

回答by Ben Lindsay

It's not the cutting part that Excel doesn't like--it's the pasting part. Pasteand PasteSpecialare 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:

Excel 不喜欢的不是剪切部分——而是粘贴部分。Paste并且PasteSpecial是您使用工作表对象（您粘贴到的位置）而不是图像（您粘贴的东西）调用的方法。我不知道您是想缩小宽度并保持高度不变，还是想均匀地缩放两个尺寸。如果你想均匀地缩放，试试这个：

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 = Falseis 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.

如果图片最初位于单元格的角落，它们的位置应保持完全相同。否则，这会将图像的左上角与最近的单元格角对齐。这Application.CutCopyMode = False是粘贴后的好习惯。它告诉 Excel 擦除剪贴板并返回正常操作，而不是等待您再次粘贴。希望这可以帮助。

回答by James

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.

谢谢回答我的问题！这是我根据您的建议最终使用的代码。程序运行了几分钟（文件中有超过 5000 张图片 - 哎呀！）。然而，等待是值得的，因为它将文件大小缩小了一半。

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