[UMU WSH 教程](43) WIA 應用實例 - 批量轉換圖片格式

[UMU WSH 教程](42) FSO 應用實例 - 批量刪除文件

UMU WSH 教程代碼下載：http://sdrv.ms/ZpPPaS

UMU WSH Git：http://git.oschina.net/umu618/umu-wsh

　　bmp 格式的圖片佔空間比較大，轉爲無損壓縮的 png 格式能夠節省空間。下面利用 FSO 和 WIA 對象批量轉換 bmp 文件爲 png 格式。

 

' 43_bmp2png.VBS
' UMU @ 0:23 2012/10/14
' [UMU WSH 教程](43) WIA 應用實例 - 批量轉換圖片格式
Option Explicit

Const wiaFormatPNG = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
Const APP_TITLE = "UMU.Script.Tools.bmp2png"

Dim objArgs, objFSO


Set objArgs = WScript.Arguments
Set objFSO = CreateObject( "Scripting.FileSystemObject" )

If objArgs.Count = 0 Then
    Dim objWSH
    Dim szSendto, szCopyTo


    MsgBox "本程序用來把 bmp 格式圖片轉換爲 png 格式。" & vbCrLf & _
        "請把要處理的文件或文件夾拖放到本程序的圖標上！", _
        vbInformation, APP_TITLE

    Set objWSH = CreateObject( "WScript.Shell" )
    szSendto = objWSH.SpecialFolders("SendTo")
    szCopyTo = szSendto & "\bmp2png.VBE"

    If Not objFSO.FileExists(szCopyTo) Then
        If vbOK = MsgBox("本程序用來把 bmp 格式圖片轉換爲 png 格式。" & vbCrLf & _
            "請把要處理的文件或文件夾拖放到本程序的圖標上！" & vbCrLf & vbCrLf & _
            "提示：您能夠把此文件放在 Sendto 目錄裏，而後使用右鍵菜單的「發送到」。" & vbCrLf & _
            "您的 Sendto 目錄是 " & szSendto & vbCrLf & "按「肯定」執行復制操做。", _
            vbOKCancel + vbInformation, APP_TITLE) Then
            
            objFSO.CopyFile WScript.ScriptFullName, szCopyTo

            If vbYes = MsgBox("是否查看 Sendto 目錄？", vbQuestion + vbYesNo, APP_TITLE) Then
                objWSH.Run "%SystemRoot%\explorer.exe /n, /select," & szCopyTo
            End If
        End If
    End If

    Set objFSO = Nothing
    Set objWSH = Nothing
    Set objArgs = Nothing
    WScript.Quit
End If

Dim fDelete

fDelete = MsgBox( "轉換後是否刪除原 bmp 文件？", vbYesNoCancel + vbQuestion, "詢問" )
If vbCancel = fDelete Then
    Set objArgs = Nothing
    WScript.Quit
End If

Dim ar, nSucceededCount, nFailedCount, nPngExistsCount


nSucceededCount = 0
nFailedCount = 0
nPngExistsCount = 0

For Each ar In objArgs
    If objFSO.FolderExists(ar) Then
        Call BmpToPng_s(ar)
    ElseIf objFSO.FileExists(ar) Then
        Call BmpToPng(ar)
    End If
Next

Set objArgs = Nothing
Set objFSO = Nothing

MsgBox "轉換 bmp 文件 " & nSucceededCount & " 個，失敗 " & nFailedCount & _
    " 個，PNG 文件已經存在 " & nPngExistsCount & " 個！", 4160, "整個世界清淨了！"

Private Sub BmpToPng_s( ByVal szFolderPath )
    'On Error Resume Next


    Dim rfd, fs, f, fds, fd


    Set rfd = objFSO.GetFolder( szFolderPath )
    Set fs = rfd.Files
    For Each f In fs
        BmpToPng f.Path
    Next

    Set fds = rfd.SubFolders
    For Each fd In fds
        BmpToPng_s fd.Path
    Next
End Sub

Private Sub BmpToPng( ByVal szFilePath )
    On Error Resume Next


    Dim szExt, szPng


    szExt = Right( szFilePath, 4 )
    If StrComp( szExt, ".bmp", vbTextCompare ) Then
        Exit Sub
    End If

    szPng = Left(szFilePath, Len(szFilePath) - 4) & ".png"
    If objFSO.FileExists(szPng) Then
        nPngExistsCount = nPngExistsCount + 1
        Exit Sub
    End If

    Err.Clear

    Dim objIF, objIP


    Set objIF = CreateObject( "WIA.ImageFile" )
    Set objIP = CreateObject( "WIA.ImageProcess" )

    objIF.LoadFile szFilePath
    If Err.Number Then
        nFailedCount = nFailedCount + 1
        Exit Sub
    End If

    If objIF.FormatID <> wiaFormatPNG Then
        objIP.Filters.Add objIP.FilterInfos("Convert").FilterID
        objIP.Filters(1).Properties("FormatID").Value = wiaFormatPNG
        Set objIF = objIP.Apply(objIF)
        objIF.SaveFile szPng

        If Err.Number Then
            Set objIF = Nothing
            Set objIP = Nothing
            nFailedCount = nFailedCount + 1
            Exit Sub
        End If

        nSucceededCount = nSucceededCount + 1

        If vbYes = fDelete Then
            objFSO.DeleteFile szFilePath
        End If
    End If

    Set objIF = Nothing
    Set objIP = Nothing
End Sub