對(duì)于一兩張圖片的單獨(dú)壓縮，可以通過(guò)Excel表格手動(dòng)縮放或使用其他軟件進(jìn)行處理。但如果需要壓縮大量的圖片，手動(dòng)操作就會(huì)變得非常繁瑣。這時(shí)候，可以通過(guò)VBA程序來(lái)實(shí)現(xiàn)批量壓縮。 步驟一：打開(kāi)VBE編輯

對(duì)于一兩張圖片的單獨(dú)壓縮，可以通過(guò)Excel表格手動(dòng)縮放或使用其他軟件進(jìn)行處理。但如果需要壓縮大量的圖片，手動(dòng)操作就會(huì)變得非常繁瑣。這時(shí)候，可以通過(guò)VBA程序來(lái)實(shí)現(xiàn)批量壓縮。

步驟一：打開(kāi)VBE編輯器

首先，打開(kāi)Excel表格，然后點(diǎn)擊【開(kāi)發(fā)工具】和【Visual Basic】，調(diào)出VBE編輯器。（也可以使用快捷鍵【Alt F11】）

步驟二：插入模塊

VBE編輯器的菜單欄上方點(diǎn)擊【插入】和【模塊】，在模塊代碼框內(nèi)輸入以下VBA程序：

Sub Shapes_Zoom()
    Dim Arr, Str1, Str2, Shp, myPath1, myPath2, MyPos, Na, i1, i2
    On Error Resume Next '忽略運(yùn)行中可能出現(xiàn)的錯(cuò)誤
      False '關(guān)閉工作表更新，提高運(yùn)行速度
    Application.DisplayAlerts  False '忽略報(bào)警提示
    Arr  Array("jpg", "jpeg", "png", "bmp", "gif", "tif") '圖片格式集合
    myPath1  "D:ABCDE" '源文件圖片路徑
    myPath2  "D:ABCDEFGH" '壓縮后圖片導(dǎo)出路徑
    MkDir myPath2 '新建文件夾
    Set mySheet1  ("Sheet1") '定義Sheet1工作表
    Set fs  CreateObject("") '計(jì)算機(jī)文件訪問(wèn)
    Set fo  (myPath1) '獲取文件夾
    Windows(1).Zoom  100 '當(dāng)前excel窗口放到到100%
    For Each Shp In  '對(duì)每張圖片進(jìn)行掃描，然后刪除
    Next
    For Each fi In  '掃描文件夾里面的每一個(gè)文件
        i1  0
        i2  0
        Na   '獲取文件名稱(chēng)
        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) '截取名稱(chēng)
                If UBound(Filter(Arr, Str1))  0 Then '如果是圖片格式的文件，則
                    (myPath1  Na).Select '插入圖片并選擇
                    For Each Shp In  '對(duì)每張圖片進(jìn)行掃描
                        Shp.LockAspectRatio  msoTrue '鎖定圖片的比例
                         0.5, msoTrue, msoScaleFromTopLeft '縮放50%
                    Next
                    For Each Shp In  '對(duì)每張圖片進(jìn)行掃描
                         '復(fù)制圖片
                        Set Ch  (1, 0, 0, 1, 1) '新建圖表
                        Ch.Height  Shp.Height '圖表高度圖片高度
                        Ch.Width  Shp.Width '圖表寬度圖片寬度
                         '把圖片粘貼到圖表里邊
                          msoFalse '圖表背景無(wú)填充
                          msoFalse '圖表邊框無(wú)線條
                         myPath2  Na '導(dǎo)出壓縮圖片
                         '刪除圖表
                         '刪除圖片
                    Next
                      False '清空剪切板
                End If
            End If
        Loop Until MyPos  0
    Next
      False '清空剪切板
    Application.DisplayAlerts  True '恢復(fù)報(bào)警提示
      True '恢復(fù)更新顯示
End Sub

步驟三：運(yùn)行程序

檢查確認(rèn)以上代碼沒(méi)有任何問(wèn)題后，在功能區(qū)中點(diǎn)擊“運(yùn)行”圖標(biāo)運(yùn)行程序。

步驟四：查看壓縮后的圖片

程序運(yùn)行完成后，打開(kāi)存放壓縮圖片的文件夾，你將會(huì)看到圖片已經(jīng)被成功批量壓縮。