单独压缩一两张图片，可以通过Excel表格手动缩放，或者通过其他软件进行缩放。如果要压缩的图片较多，通过手动压缩的方法就比较费劲，此时可以通过VBA程序进行压缩。工具/原料more操作硬件：计算机操作系统：Windows 7办公软件：Excel 2010方法/步骤1/6分步阅读

打开Excel表格，点击【开发工具】、【Visual Basic】调出VBE编辑器。（也可以使用【Alt+F11】组合键调出VBE编辑器）

2/6

VBE编辑器的菜单栏上面点击【插入】、【模块】。

3/6

模块代码框里边输入以下VBA程序。

Sub Shapes_Zoom()

Dim Arr, Str1, Str2, Shp, myPath1, myPath2, MyPos, Na, i1, i2

On Error Resume Next 忽略运行中可能出现的错误

Application.ScreenUpdating = False 关闭工作表更新，提高运行速度

Application.DisplayAlerts = False 忽略报警提示

Arr = Array(.jpg, .jpeg, .png, .bmp, .gif, .tif) 图片格式集合

myPath1 = D:\ABCDE\ 源文件图片路径

myPath2 = D:\ABCDE\FGH\ 压缩后图片导出路径

MkDir myPath2 新建文件夹

Set mySheet1 = ThisWorkbook.Worksheets(Sheet1) 定义Sheet1工作表

Set fs = CreateObject(Scripting.FileSystemObject) 计算机文件访问

Set fo = fs.GetFolder(myPath1) 获取文件夹

Windows(1).Zoom = 100 当前excel窗口放到到100%

For Each Shp In mySheet1.Shapes 对每张图片进行扫描，然后删除

Shp.Delete

Next

For Each fi In fo.Files 扫描文件夹里面的每一个文件

i1 = 0

i2 = 0

Na = fi.Name 获取文件名称

Do

i1 = MyPos 寄存上次获取“.”的位置

i2 = i2 + 1

MyPos = InStr(MyPos + 1, Na, .) 获取.存在的位置

If MyPos = 0 And i2 1 Then

Str1 = Right(Na, Len(Na) - i1 + 1) 截取后缀名

Str2 = Left(Na, i1 - 1) 截取名称

If UBound(Filter(Arr, Str1)) = 0 Then 如果是图片格式的文件，则

mySheet1.Pictures.Insert(myPath1 Na).Select 插入图片并选择

For Each Shp In mySheet1.Shapes 对每张图片进行扫描

Shp.LockAspectRatio = msoTrue 锁定图片的比例

Shp.ScaleHeight 0.5, msoTrue, msoScaleFromTopLeft 缩放50%

Next

For Each Shp In mySheet1.Shapes 对每张图片进行扫描

Shp.Copy 复制图片

Set Ch = mySheet1.Shapes.AddChart(1, 0, 0, 1, 1) 新建图表

Ch.Height = Shp.Height 图表高度=图片高度

Ch.Width = Shp.Width 图表宽度=图片宽度

Ch.Chart.Paste 把图片粘贴到图表里边

Ch.Fill.Visible = msoFalse 图表背景无填充

Ch.Line.Visible = msoFalse 图表边框无线条

Ch.Chart.Export myPath2 Na 导出压缩图片

Ch.Delete 删除图表

Shp.Delete 删除图片

Application.CutCopyMode = False 清空剪切板

Next

End If

Exit Do 退出Do循环

End If

Loop

Next

Application.CutCopyMode = False 清空剪切板

Application.DisplayAlerts = True 恢复报警提示

Application.ScreenUpdating = True 恢复更新显示

End Sub

4/6

检查确认无误后，功能区里边点击“运行”图标运行程序。

5/6

程序运行完成后，打开压缩图片存放的文件夹。

6/6

将会看到图片已经被批量压缩。

VBA程序解读1/1

VBA程序思路分享、解读：

1、先建立一个图片格式的集合Array(.jpg, .jpeg……)，便于后续判断该文件是否属于图片格式，如果不是图片格式，则不用插入Excel表格，也就不用压缩了。

2、对Sheet1里面所有的图片删除，主要是避免干扰，同时，导出完成之后，再将图表和图片删除，以避免Excel文件过大而停止运行。

3、获取文件格式，主要是通过截取文件名最后一个点号（.）及之后的字符，再与图片格式集合比对。如果是图片格式，则UBound(Filter(Arr, Str1))为0，否则为-1。

4、Excel表格里面的图片不能直接导出，但可以通过图表的形式将其导出。

注意事项

数据无价，执行VBA程序前先做好Excel表格、图片数据备份，以免丢失而无法找回。

VBA按比例压缩的图片像素与设定的百分比可能会存在一点误差。

操作界面及功能可能因软件版本、软件设置、操作系统等不同而存在差异。

程序运行的快慢主要取决于硬件设备和压缩图片的数量。

EXCEL图片压缩