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

【问题标题】：Resize and change the format of multiple pictures using Excel VBA使用 Excel VBA 调整多张图片的大小和格式
【发布时间】：2014-10-24 10:14:03
【问题描述】：

我有一个 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

【问题讨论】：

标签： image excel vba

【解决方案1】：

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

如果你只是想缩小宽度并保持高度不变，试试这个：

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

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

【讨论】：

太棒了。谢谢您的帮助！！！！实际上，我有一些横向模式的图片和其他纵向模式的图片，我想缩小以适应现有的单元格大小 - 所以我使用了您建议的 For Each 构造并添加了 if, then, else 构造来确定图片是否在纵向或横向，并相应地重新缩放（基于横向图片的宽度或基于纵向的高度）。由于某些单元格有多个小图片，因此我使用 .top 和 .left 属性代替了 TopLeftCell。

【解决方案2】：

感谢您回答我的问题！这是我根据您的建议最终使用的代码。该程序运行了几分钟（文件中有超过 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

【讨论】：