使用VBA批量压缩Excel中的图片

对于一两张图片的单独压缩，可以通过Excel表格手动缩放或使用其他软件进行处理。但如果需要压缩大量的图片，手动操作就会变得非常繁琐。这时候，可以通过VBA程序来实现批量压缩。

步骤一：打开VBE编辑器

首先，打开Excel表格，然后点击【开发工具】和【Visual Basic】，调出VBE编辑器。（也可以使用快捷键【Alt F11】）

步骤二：插入模块

VBE编辑器的菜单栏上方点击【插入】和【模块】，在模块代码框内输入以下VBA程序：

Sub Shapes_Zoom()
    Dim Arr, Str1, Str2, Shp, myPath1, myPath2, MyPos, Na, i1, i2
    On Error Resume Next '忽略运行中可能出现的错误
      False '关闭工作表更新，提高运行速度
    Application.DisplayAlerts  False '忽略报警提示
    Arr  Array("jpg", "jpeg", "png", "bmp", "gif", "tif") '图片格式集合
    myPath1  "D:ABCDE" '源文件图片路径
    myPath2  "D:ABCDEFGH" '压缩后图片导出路径
    MkDir myPath2 '新建文件夹
    Set mySheet1  ("Sheet1") '定义Sheet1工作表
    Set fs  CreateObject("") '计算机文件访问
    Set fo  (myPath1) '获取文件夹
    Windows(1).Zoom  100 '当前excel窗口放到到100%
    For Each Shp In  '对每张图片进行扫描，然后删除
    Next
    For Each fi In  '扫描文件夹里面的每一个文件
        i1  0
        i2  0
        Na   '获取文件名称
        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 '如果是图片格式的文件，则
                    (myPath1  Na).Select '插入图片并选择
                    For Each Shp In  '对每张图片进行扫描
                        Shp.LockAspectRatio  msoTrue '锁定图片的比例
                         0.5, msoTrue, msoScaleFromTopLeft '缩放50%
                    Next
                    For Each Shp In  '对每张图片进行扫描
                         '复制图片
                        Set Ch  (1, 0, 0, 1, 1) '新建图表
                        Ch.Height  Shp.Height '图表高度图片高度
                        Ch.Width  Shp.Width '图表宽度图片宽度
                         '把图片粘贴到图表里边
                          msoFalse '图表背景无填充
                          msoFalse '图表边框无线条
                         myPath2  Na '导出压缩图片
                         '删除图表
                         '删除图片
                    Next
                      False '清空剪切板
                End If
            End If
        Loop Until MyPos  0
    Next
      False '清空剪切板
    Application.DisplayAlerts  True '恢复报警提示
      True '恢复更新显示
End Sub

步骤三：运行程序

检查确认以上代码没有任何问题后，在功能区中点击“运行”图标运行程序。

步骤四：查看压缩后的图片

程序运行完成后，打开存放压缩图片的文件夹，你将会看到图片已经被成功批量压缩。

版权声明：本文内容由互联网用户自发贡献，本站不承担相关法律责任.如有侵权/违法内容,本站将立刻删除。