1、打开Excel表格，点击【开发工具】、【Visual Basic】调出VBE编辑器。（也可以使用【Alt+F11】组合键调出VBE编辑器）
2、VBE编辑器的菜单栏上面点击【插入】、【模块】。
3、模块代码框里边输入以下VBA程序。Sub Shapes_Zoom()Dim Arr, Str1, Str2, Shp, myPath1, myPath2, MyPos, Na, i1, i2On 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.DeleteNextFor Each fi In fo.Files '扫描文件夹里面的每一个文件i1 = 0i2 = 0Na = 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 IfLoopNextApplication.CutCopyMode = False '清空剪切板Application.DisplayAlerts = True '恢复报警提示Application.ScreenUpdating = True '恢复更新显示End Sub
4、检查确认无误后，功能区里边点击“运行”图标运行程序。
5、程序运行完成后，打开压缩图片存放的文件夹。
6、将会看到图片已经被批量压缩。
